diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 0bb2ebdd..b7946abe 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -200,6 +200,7 @@ jobs: # No changed recipes if [ "$SCIPY_WILL_BE_TESTED" == "true" ]; then echo "recipes=tag:core,scipy" >> "$GITHUB_OUTPUT" + sed -i 's/unvendor-tests: true/unvendor-tests: false/' packages/scipy/meta.yaml echo "Building: tag:core,scipy (no changes + scipy trigger)" else echo "recipes=tag:core" >> "$GITHUB_OUTPUT" @@ -211,9 +212,11 @@ jobs: # Check if scipy is already in changed recipes to avoid duplication if [[ "$CHANGED_RECIPES" == *"scipy"* ]]; then echo "recipes=$CHANGED_RECIPES,tag:core" >> "$GITHUB_OUTPUT" + sed -i 's/unvendor-tests: true/unvendor-tests: false/' packages/scipy/meta.yaml echo "Building: $CHANGED_RECIPES,tag:core (scipy already included in changes)" else echo "recipes=$CHANGED_RECIPES,tag:core,scipy" >> "$GITHUB_OUTPUT" + sed -i 's/unvendor-tests: true/unvendor-tests: false/' packages/scipy/meta.yaml echo "Building: $CHANGED_RECIPES,tag:core,scipy (changes + scipy trigger)" fi else @@ -443,30 +446,55 @@ jobs: with: node-version: "24" - - name: Prepare SciPy test environment + # - name: Prepare SciPy test environment + # run: | + # # First, install any version of pyodide from npm + # # to get the file structure + # npm install pyodide + + # # Copy the Pyodide runtime to the dist folder + # ./tools/copy_pyodide_runtime.sh ./dist + + # # Copy the Pyodide files from the dist folder to the + # # node_modules/pyodide folder, so that the SciPy tests + # # can find them + # cp -f dist/* node_modules/pyodide + + # # Delete conftest.py from repo root to avoid conflicts + # rm -rf conftest.py + + # # Change scipy-conftest.py to conftest.py as pytest + # # doesn't seem to recognise it otherwise + # mv packages/scipy/scipy-conftest.py packages/scipy/conftest.py + + # - name: Run SciPy test suite + # run: node scipy-pytest.js --pyargs scipy -m "not slow" -vra + # working-directory: packages/scipy/ + + - name: Prepare SciPy test suite run: | - # First, install any version of pyodide from npm - # to get the file structure - npm install pyodide + pyodide venv .venv-pyodide + source .venv-pyodide/bin/activate - # Copy the Pyodide runtime to the dist folder - ./tools/copy_pyodide_runtime.sh ./dist + pip install pytest hypothesis pooch lzma + pip install dist/scipy-*.whl - # Copy the Pyodide files from the dist folder to the - # node_modules/pyodide folder, so that the SciPy tests - # can find them - cp -f dist/* node_modules/pyodide + - name: Remove problematic SciPy test files + run: | + find .venv-pyodide -name "test_fortran.py" -delete + find .venv-pyodide -name "test_odeint_jac.py" -delete + find .venv-pyodide/lib/python*/site-packages/scipy -name "pytest.ini" -delete - # Delete conftest.py from repo root to avoid conflicts + - name: Copy test config files + run: | rm -rf conftest.py - - # Change scipy-conftest.py to conftest.py as pytest - # doesn't seem to recognise it otherwise mv packages/scipy/scipy-conftest.py packages/scipy/conftest.py - name: Run SciPy test suite - run: node scipy-pytest.js --pyargs scipy -m "not slow" -vra - working-directory: packages/scipy/ + run: | + source .venv-pyodide/bin/activate + cd packages/scipy + pytest -vra --pyargs scipy release: runs-on: ubuntu-latest diff --git a/packages/scipy/meta.yaml b/packages/scipy/meta.yaml index fb83187b..fb617dce 100644 --- a/packages/scipy/meta.yaml +++ b/packages/scipy/meta.yaml @@ -1,7 +1,6 @@ package: name: scipy - version: 1.14.1 - pinned: true + version: 1.16.0 tag: - min-scipy-stack top-level: @@ -18,8 +17,8 @@ package: # subroutine. Try deleting it. source: - url: https://files.pythonhosted.org/packages/62/11/4d44a1f274e002784e4dbdb81e0ea96d2de2d1045b2132d5af62cc31fd28/scipy-1.14.1.tar.gz - sha256: 5a275584e726026a5699459aa72f828a610821006228e841b94275c4a7c08417 + url: https://files.pythonhosted.org/packages/source/s/scipy/scipy-1.16.0.tar.gz + sha256: b5ef54021e832869c8cfb03bc3bf20366cbcd426e02a58e8a58d7584dfbb8f62 patches: - patches/0001-Fix-dstevr-in-special-lapack_defs.h.patch @@ -28,18 +27,14 @@ source: - patches/0004-make-int-return-values.patch - patches/0005-Fix-fitpack.patch - patches/0006-Fix-gees-calls.patch - - patches/0007-MAINT-linalg-Remove-id_dist-Fortran-files.patch - - patches/0008-Mark-mvndst-functions-recursive.patch - - patches/0009-Make-sreorth-recursive.patch - - patches/0010-Link-openblas-with-modules-that-require-f2c.patch - - patches/0011-Remove-fpchec-inline-if-then-endif-constructs.patch # remove with SciPy v1.15.0 - - patches/0012-Remove-chla_transtype.patch - - patches/0013-Set-wrapper-return-type-to-int.patch - - patches/0014-Skip-svd_gesdd-test.patch # remove with SciPy v1.15.0 - - patches/0015-Remove-f2py-generators.patch - - patches/0016-Make-sf_error_state_lib-a-static-library.patch - - patches/0017-Remove-test-modules-that-fail-to-build.patch - - patches/0018-Fix-lapack-larfg-function-signature.patch + - patches/0007-Make-sreorth-recursive.patch + - patches/0008-Link-openblas-with-modules-that-require-f2c.patch + - patches/0009-Remove-chla_transtype.patch + - patches/0010-Set-wrapper-return-type-to-int.patch + - patches/0011-Remove-test-modules-that-fail-to-build.patch + - patches/0012-Fix-lapack-larfg-function-signature.patch + - patches/0013-ENH-MAINT-sparse.linalg-rewrite-ARPACK-in-C-22748.patch + - patches/0014-Remove-f2py-generators.patch build: # NumPy 2.1 disabled visibility for symbols outside of extension modules @@ -98,7 +93,12 @@ build: sed -i 's/extern void/extern int/g' scipy/optimize/__minpack.h sed -i 's/void/int/g' scipy/linalg/cython_blas_signatures.txt sed -i 's/void/int/g' scipy/linalg/cython_lapack_signatures.txt + sed -i 's/^void/int/g' scipy/linalg/_common_array_utils.h + sed -i 's/^void/int/g' scipy/interpolate/src/_fitpackmodule.c + sed -i 's/^void/int/g' scipy/interpolate/src/__fitpack.h + sed -i 's/^void/int/g' scipy/interpolate/src/__fitpack.cc + sed -i 's/void BLAS_FUNC/int BLAS_FUNC/g' scipy/interpolate/src/__fitpack.h sed -i 's/extern void/extern int/g' scipy/sparse/linalg/_dsolve/SuperLU/SRC/*.{c,h} sed -i 's/PUBLIC void/PUBLIC int/g' scipy/sparse/linalg/_dsolve/SuperLU/SRC/*.{c,h} @@ -107,16 +107,36 @@ build: sed -i 's/void \(.\)print/int \1/g' scipy/sparse/linalg/_dsolve/SuperLU/SRC/*.{c,h} sed -i 's/TYPE_GENERIC_FUNC(\(.*\), void)/TYPE_GENERIC_FUNC(\1, int)/g' scipy/sparse/linalg/_dsolve/_superluobject.h + sed -i 's/^void/int/g' scipy/optimize/__nnls.h + sed -i 's/^void/int/g' scipy/optimize/__nnls.c + sed -i 's/^void/int/g' scipy/optimize/__slsqp.h + sed -i 's/^void/int/g' scipy/optimize/__slsqp.c + sed -i 's/^static void/static int/g' scipy/optimize/__slsqp.c + sed -i 's/^void/int/g' scipy/optimize/_trlib/trlib_private.h sed -i 's/^void/int/g' scipy/optimize/_trlib/trlib/trlib_private.h sed -i 's/^void/int/g' scipy/_build_utils/src/wrap_dummy_g77_abi.c sed -i 's/, int)/)/g' scipy/optimize/_trlib/trlib_private.h sed -i 's/, 1)/)/g' scipy/optimize/_trlib/trlib_private.h + sed -i 's/^void/int/g' scipy/linalg/_matfuncs_expm.h + sed -i 's/^void/int/g' scipy/linalg/_matfuncs_expm.c + sed -i 's/^void/int/g' scipy/linalg/_matfuncs_sqrtm.h + sed -i 's/^void/int/g' scipy/linalg/_matfuncs_sqrtm.c + + sed -i 's/^void/int/g' scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.h + sed -i 's/^void/int/g' scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.h + sed -i 's/^void/int/g' scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.h + sed -i 's/^void/int/g' scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.h + sed -i 's/^void/int/g' scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.h + sed -i 's/^void/int/g' scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.h + sed -i 's/^void/int/g' scipy/spatial/qhull_misc.h sed -i 's/, size_t)/)/g' scipy/spatial/qhull_misc.h sed -i 's/,1)/)/g' scipy/spatial/qhull_misc.h + sed -i 's/^void/int/g' scipy/optimize/__lbfgsb.h + # Input error causes "duplicate symbol" linker errors. Empty out the file. echo "" > scipy/sparse/linalg/_dsolve/SuperLU/SRC/input_error.c diff --git a/packages/scipy/patches/0001-Fix-dstevr-in-special-lapack_defs.h.patch b/packages/scipy/patches/0001-Fix-dstevr-in-special-lapack_defs.h.patch index ca6d80a0..6ccd6501 100644 --- a/packages/scipy/patches/0001-Fix-dstevr-in-special-lapack_defs.h.patch +++ b/packages/scipy/patches/0001-Fix-dstevr-in-special-lapack_defs.h.patch @@ -1,7 +1,7 @@ From 45a31145679c83f2719b6420f234d484b9459697 Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Fri, 18 Mar 2022 16:25:39 -0700 -Subject: [PATCH 1/18] Fix dstevr in special/lapack_defs.h +Subject: [PATCH 1/14] Fix dstevr in special/lapack_defs.h --- scipy/special/lapack_defs.h | 5 ++--- diff --git a/packages/scipy/patches/0002-int-to-string.patch b/packages/scipy/patches/0002-int-to-string.patch index 7a172cb2..1aae3b7b 100644 --- a/packages/scipy/patches/0002-int-to-string.patch +++ b/packages/scipy/patches/0002-int-to-string.patch @@ -1,7 +1,7 @@ From d53ade3f03ba3557fd50fb38990d605f4ae7f8f1 Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Sat, 25 Dec 2021 18:04:18 -0800 -Subject: [PATCH 2/18] int to string +Subject: [PATCH 2/14] int to string f2c does not handle implicit casts of function arguments correctly. The msg argument of `xerrwv` is defined to be an `int *`, and then implicitly cast diff --git a/packages/scipy/patches/0003-gemm_-no-const.patch b/packages/scipy/patches/0003-gemm_-no-const.patch index 3840f745..1207ca3a 100644 --- a/packages/scipy/patches/0003-gemm_-no-const.patch +++ b/packages/scipy/patches/0003-gemm_-no-const.patch @@ -1,7 +1,7 @@ From e528227dd37c8b0512381992c222789a114e3169 Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Sat, 18 Dec 2021 11:41:15 -0800 -Subject: [PATCH 3/18] gemm_ no const +Subject: [PATCH 3/14] gemm_ no const cgemm, dgemm, sgemm, and zgemm are declared with `const` in slu_cdefs.h, but other places don't have the cosnt causing compile errors. diff --git a/packages/scipy/patches/0004-make-int-return-values.patch b/packages/scipy/patches/0004-make-int-return-values.patch index 2fdd4659..7d915dd6 100644 --- a/packages/scipy/patches/0004-make-int-return-values.patch +++ b/packages/scipy/patches/0004-make-int-return-values.patch @@ -1,7 +1,7 @@ From a86a2304fd925f815bbb0e0753e46a7b863e2de2 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Wed, 6 Apr 2022 21:25:13 -0700 -Subject: [PATCH 4/18] make int return values +Subject: [PATCH 4/14] make int return values The return values of f2c functions are insignificant in most cases, so often it is treated as returning void, when it really should return int (values are @@ -240,21 +240,20 @@ index 67e83bcc77..e5757d5c4d 100644 /* Macro definitions */ diff --git a/scipy/sparse/linalg/_dsolve/SuperLU/SRC/slu_scomplex.h b/scipy/sparse/linalg/_dsolve/SuperLU/SRC/slu_scomplex.h -index 83be8c971f..047a07ce9c 100644 +index 1e53fbca5..b35313ccb 100644 --- a/scipy/sparse/linalg/_dsolve/SuperLU/SRC/slu_scomplex.h +++ b/scipy/sparse/linalg/_dsolve/SuperLU/SRC/slu_scomplex.h -@@ -27,8 +27,9 @@ at the top-level directory. - +@@ -28,7 +28,9 @@ at the top-level directory. #ifndef SCOMPLEX_INCLUDE #define SCOMPLEX_INCLUDE -- + -typedef struct { float r, i; } singlecomplex; -+#include"scipy_slu_config.h" ++#include "scipy_slu_config.h" +// defined in CLAPACK +//typedef struct { float r, i; } singlecomplex; - - /* Macro definitions */ + #if defined(SUPERLU_TYPEDEF_COMPLEX) || DOXYGEN + //! \brief backward compatibility with older versions of SuperLU diff --git a/scipy/sparse/linalg/_dsolve/_superlu_utils.c b/scipy/sparse/linalg/_dsolve/_superlu_utils.c index 49b928a431..0822687719 100644 --- a/scipy/sparse/linalg/_dsolve/_superlu_utils.c diff --git a/packages/scipy/patches/0005-Fix-fitpack.patch b/packages/scipy/patches/0005-Fix-fitpack.patch index 1df3145c..1590f204 100644 --- a/packages/scipy/patches/0005-Fix-fitpack.patch +++ b/packages/scipy/patches/0005-Fix-fitpack.patch @@ -1,7 +1,7 @@ From c784d3a1ee38da88943364de4ea847a3b9cd155f Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Tue, 30 Aug 2022 11:51:53 -0700 -Subject: [PATCH 5/18] Fix fitpack +Subject: [PATCH 5/14] Fix fitpack --- scipy/interpolate/fitpack/dblint.f | 9 ++++----- diff --git a/packages/scipy/patches/0006-Fix-gees-calls.patch b/packages/scipy/patches/0006-Fix-gees-calls.patch index feabf913..7e51670b 100644 --- a/packages/scipy/patches/0006-Fix-gees-calls.patch +++ b/packages/scipy/patches/0006-Fix-gees-calls.patch @@ -1,7 +1,7 @@ From 8addc1da35bc63df651946ef14c723797a431e0c Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Mon, 26 Jun 2023 20:12:25 -0700 -Subject: [PATCH 6/18] Fix gees calls +Subject: [PATCH 6/14] Fix gees calls --- scipy/linalg/flapack_gen.pyf.src | 8 ++++---- diff --git a/packages/scipy/patches/0007-MAINT-linalg-Remove-id_dist-Fortran-files.patch b/packages/scipy/patches/0007-MAINT-linalg-Remove-id_dist-Fortran-files.patch deleted file mode 100644 index e3a57c5b..00000000 --- a/packages/scipy/patches/0007-MAINT-linalg-Remove-id_dist-Fortran-files.patch +++ /dev/null @@ -1,21867 +0,0 @@ -From 12ba8a395ce04194074a24d362143c22e7ac54bd Mon Sep 17 00:00:00 2001 -From: Ilhan Polat -Date: Tue, 23 Apr 2024 09:26:38 +0200 -Subject: [PATCH 7/18] MAINT:linalg:Remove id_dist Fortran files - -[skip ci] - -ENH:linalg:Translate id_dist F77 code to Cython - -MAINT:linalg: Convert double to numpy types - -MAINT:linalg: Fix linting and a typo in interpolative code - -DOC:linalg: Remove non-compliant dash character - -MAINT:linalg: Modify meson file for id_dist F77 translation - -[skip ci] - -MAINT:linalg: Adjust public api for the translated funcs - -[skip ci] - -ENH:linalg: Modify function signatures for interpolative - -[skip ci] - -TST:linalg: Adjust tests for the id_dist translation - -MAINT:linalg:Remove fortran wrappers for id_dist - -[skip ci] - -MAINT:linalg:Modify mypy.ini for interpolative Cython code - -DOC:linalg: Adjust interpolative docs due to new Cython code - -DOC:linalg: Fix grammar and typos ---- - mypy.ini | 2 +- - scipy/linalg/_decomp_interpolative.pyx | 1992 +++++++++++ - scipy/linalg/_interpolative_backend.py | 1681 --------- - scipy/linalg/interpolative.py | 316 +- - scipy/linalg/meson.build | 55 +- - scipy/linalg/src/id_dist/README.txt | 6 - - scipy/linalg/src/id_dist/doc/doc.bib | 19 - - scipy/linalg/src/id_dist/doc/doc.tex | 977 ------ - scipy/linalg/src/id_dist/doc/supertabular.sty | 483 --- - scipy/linalg/src/id_dist/src/dfft.f | 3014 ----------------- - scipy/linalg/src/id_dist/src/id_rand.f | 379 --- - scipy/linalg/src/id_dist/src/id_rtrans.f | 746 ---- - scipy/linalg/src/id_dist/src/idd_frm.f | 525 --- - scipy/linalg/src/id_dist/src/idd_house.f | 288 -- - scipy/linalg/src/id_dist/src/idd_id.f | 560 --- - scipy/linalg/src/id_dist/src/idd_id2svd.f | 384 --- - scipy/linalg/src/id_dist/src/idd_qrpiv.f | 893 ----- - scipy/linalg/src/id_dist/src/idd_sfft.f | 443 --- - scipy/linalg/src/id_dist/src/idd_snorm.f | 400 --- - scipy/linalg/src/id_dist/src/idd_svd.f | 409 --- - scipy/linalg/src/id_dist/src/iddp_aid.f | 386 --- - scipy/linalg/src/id_dist/src/iddp_asvd.f | 180 - - scipy/linalg/src/id_dist/src/iddp_rid.f | 376 -- - scipy/linalg/src/id_dist/src/iddp_rsvd.f | 216 -- - scipy/linalg/src/id_dist/src/iddr_aid.f | 208 -- - scipy/linalg/src/id_dist/src/iddr_asvd.f | 114 - - scipy/linalg/src/id_dist/src/iddr_rid.f | 155 - - scipy/linalg/src/id_dist/src/iddr_rsvd.f | 157 - - scipy/linalg/src/id_dist/src/idz_frm.f | 419 --- - scipy/linalg/src/id_dist/src/idz_house.f | 298 -- - scipy/linalg/src/id_dist/src/idz_id.f | 566 ---- - scipy/linalg/src/id_dist/src/idz_id2svd.f | 389 --- - scipy/linalg/src/id_dist/src/idz_qrpiv.f | 898 ----- - scipy/linalg/src/id_dist/src/idz_sfft.f | 210 -- - scipy/linalg/src/id_dist/src/idz_snorm.f | 407 --- - scipy/linalg/src/id_dist/src/idz_svd.f | 438 --- - scipy/linalg/src/id_dist/src/idzp_aid.f | 390 --- - scipy/linalg/src/id_dist/src/idzp_asvd.f | 207 -- - scipy/linalg/src/id_dist/src/idzp_rid.f | 379 --- - scipy/linalg/src/id_dist/src/idzp_rsvd.f | 244 -- - scipy/linalg/src/id_dist/src/idzr_aid.f | 209 -- - scipy/linalg/src/id_dist/src/idzr_asvd.f | 118 - - scipy/linalg/src/id_dist/src/idzr_rid.f | 156 - - scipy/linalg/src/id_dist/src/idzr_rsvd.f | 159 - - scipy/linalg/src/id_dist/src/prini.f | 113 - - scipy/linalg/tests/test_interpolative.py | 78 +- - 46 files changed, 2159 insertions(+), 18883 deletions(-) - create mode 100644 scipy/linalg/_decomp_interpolative.pyx - delete mode 100644 scipy/linalg/_interpolative_backend.py - delete mode 100644 scipy/linalg/src/id_dist/README.txt - delete mode 100644 scipy/linalg/src/id_dist/doc/doc.bib - delete mode 100644 scipy/linalg/src/id_dist/doc/doc.tex - delete mode 100644 scipy/linalg/src/id_dist/doc/supertabular.sty - delete mode 100644 scipy/linalg/src/id_dist/src/dfft.f - delete mode 100644 scipy/linalg/src/id_dist/src/id_rand.f - delete mode 100644 scipy/linalg/src/id_dist/src/id_rtrans.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_frm.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_house.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_id.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_id2svd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_qrpiv.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_sfft.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_snorm.f - delete mode 100644 scipy/linalg/src/id_dist/src/idd_svd.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddp_aid.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddp_asvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddp_rid.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddp_rsvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddr_aid.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddr_asvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddr_rid.f - delete mode 100644 scipy/linalg/src/id_dist/src/iddr_rsvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_frm.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_house.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_id.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_id2svd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_qrpiv.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_sfft.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_snorm.f - delete mode 100644 scipy/linalg/src/id_dist/src/idz_svd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzp_aid.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzp_asvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzp_rid.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzp_rsvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzr_aid.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzr_asvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzr_rid.f - delete mode 100644 scipy/linalg/src/id_dist/src/idzr_rsvd.f - delete mode 100644 scipy/linalg/src/id_dist/src/prini.f - -diff --git a/mypy.ini b/mypy.ini -index 4417af39dc..4bdbdf9750 100644 ---- a/mypy.ini -+++ b/mypy.ini -@@ -140,7 +140,7 @@ ignore_missing_imports = True - [mypy-scipy.linalg._solve_toeplitz] - ignore_missing_imports = True - --[mypy-scipy.linalg._interpolative] -+[mypy-scipy.linalg._decomp_interpolative] - ignore_missing_imports = True - - [mypy-scipy.optimize._group_columns] -diff --git a/scipy/linalg/_decomp_interpolative.pyx b/scipy/linalg/_decomp_interpolative.pyx -new file mode 100644 -index 000000000..e1a5b2a62 ---- /dev/null -+++ b/scipy/linalg/_decomp_interpolative.pyx -@@ -0,0 +1,1992 @@ -+# cython: boundscheck=False -+# cython: initializedcheck=False -+# cython: wraparound=False -+# cython: cdivision=True -+# cython: cpow=True -+ -+""" -+This file is a Cython rewrite of the original Fortran code of "ID: A software package -+for low-rank approximation of matrices via interpolative decompositions, Version 0.4", -+written by Per-Gunnar Martinsson, Vladimir Rokhlin, Yoel Shkolnisky, and Mark Tygert. -+ -+The original Fortran code can be found at the last author's current website -+http://tygert.com/software.html -+ -+ -+References -+---------- -+ -+N. Halko, P.G. Martinsson, and J. A. Tropp, "Finding structure with randomness: -+probabilistic algorithms for constructing approximate matrix decompositions", -+SIAM Review, 53 (2011), pp. 217-288. DOI:10.1137/090771806 -+ -+H. Cheng, Z. Gimbutas, P.G. Martinsson, V.Rokhlin, "On the Compression of Low -+Rank Matrices", SIAM Journal of Scientific Computing, 2005, Vol.26(4), -+DOI:10.1137/030602678 -+ -+ -+ -+Copyright (C) 2024 SciPy developers -+ -+Redistribution and use in source and binary forms, with or without -+modification, are permitted provided that the following conditions are met: -+ -+a. Redistributions of source code must retain the above copyright notice, -+ this list of conditions and the following disclaimer. -+b. Redistributions in binary form must reproduce the above copyright -+ notice, this list of conditions and the following disclaimer in the -+ documentation and/or other materials provided with the distribution. -+c. Names of the SciPy Developers may not be used to endorse or promote -+ products derived from this software without specific prior written -+ permission. -+ -+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS -+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, -+OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF -+THE POSSIBILITY OF SUCH DAMAGE. -+ -+ -+Notes -+----- -+ -+The translated functions from the original Fortran77 code are as follows (with various -+internal functions subsumed into respective functions): -+ -+ idd_diffsnorm -+ idd_estrank -+ idd_findrank -+ idd_id2svd -+ idd_ldiv -+ idd_poweroftwo -+ idd_reconid -+ idd_snorm -+ iddp_aid -+ iddp_asvd -+ iddp_id -+ iddp_qrpiv -+ iddp_rid -+ iddp_rsvd -+ iddp_svd -+ iddr_aid -+ iddr_asvd -+ iddr_id -+ iddr_qrpiv -+ iddr_rid -+ iddr_rsvd -+ iddr_svd -+ idz_diffsnorm -+ idz_estrank -+ idz_findrank -+ idz_id2svd -+ idz_reconid -+ idz_snorm -+ idzp_aid -+ idzp_asvd -+ idzp_id -+ idzp_qrpiv -+ idzp_rid -+ idzp_rsvd -+ idzp_svd -+ idzr_aid -+ idzr_asvd -+ idzr_id -+ idzr_rid -+ idzr_rsvd -+ idzr_qrpiv -+ idzr_svd -+ -+""" -+ -+import numpy as np -+from numpy.typing import NDArray -+cimport numpy as cnp -+cnp.import_array() -+ -+from cpython.mem cimport PyMem_Free, PyMem_Malloc, PyMem_Realloc -+from libc.math cimport hypot -+ -+import scipy.linalg as la -+from scipy.fft import rfft, fft -+from scipy.sparse.linalg import LinearOperator -+ -+from scipy.linalg.cython_lapack cimport dlarfgp, dorm2r, zunm2r, zlarfgp -+from scipy.linalg.cython_blas cimport dnrm2, dtrsm, dznrm2, ztrsm -+ -+ -+__all__ = ['idd_estrank', 'idd_ldiv', 'idd_poweroftwo', 'idd_reconid', 'iddp_aid', -+ 'iddp_asvd', 'iddp_id', 'iddp_qrpiv', 'iddp_svd', 'iddr_aid', 'iddr_asvd', -+ 'iddr_id', 'iddr_qrpiv', 'iddr_svd', 'idz_estrank', 'idz_reconid', -+ 'idzp_aid', 'idzp_asvd', 'idzp_id', 'idzp_qrpiv', 'idzp_svd', 'idzr_aid', -+ 'idzr_asvd', 'idzr_id', 'idzr_qrpiv', 'idzr_svd', 'idd_id2svd', 'idz_id2svd' -+ # LinearOperator funcs -+ 'idd_findrank', 'iddp_rid', 'iddp_rsvd', 'iddr_rid', 'iddr_rsvd', -+ 'idz_findrank', 'idzp_rid', 'idzp_rsvd', 'idzr_rid', 'idzr_rsvd', -+ 'idd_snorm', 'idz_snorm', 'idd_diffsnorm', 'idz_diffsnorm' -+ ] -+ -+ -+def idd_diffsnorm(A: LinearOperator, B: LinearOperator, int its=20, rng=None): -+ cdef int n = A.shape[1], j = 0, intone = 1 -+ cdef cnp.float64_t snorm = 0.0 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] v1 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] v2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] u1 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] u2 -+ -+ if not rng: -+ rng = np.random.default_rng() -+ v1 = rng.uniform(low=-1., high=1., size=n) -+ v1 /= dnrm2(&n, &v1[0], &intone) -+ -+ for j in range(its): -+ u1 = A.matvec(v1) -+ u2 = B.matvec(v1) -+ u1 -= u2 -+ v1 = A.rmatvec(u1) -+ v2 = B.rmatvec(u1) -+ v1 -= v2 -+ -+ snorm = dnrm2(&n, &v1[0], &intone) -+ if snorm > 0.0: -+ v1 /= snorm -+ -+ snorm = np.sqrt(snorm) -+ -+ return snorm -+ -+ -+def idd_estrank(cnp.ndarray[cnp.float64_t, mode="c", ndim=2] a: NDArray, eps: float, -+ rng=None): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef int intone = 1, n2, nsteps = 3, row, r, nstep, cols, k, nulls -+ cdef cnp.float64_t h, alpha, beta -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=3] albetas -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau_arr -+ cdef cnp.ndarray[cnp.int64_t, mode='c', ndim=1] subselect -+ cdef cnp.float64_t *aa -+ cdef cnp.float64_t *ff -+ cdef cnp.float64_t[:, ::1] Fmemview -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] giv2x2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] rta -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] Fc -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] F -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ n2 = idd_poweroftwo(m) -+ -+ # This part is the initialization that is done via idd_frmi -+ # for a Subsampled Randomized Fourier Transfmrom (SRFT). -+ -+ # Draw (nsteps x m x 2) arrays from [-1, 1) uniformly and scale -+ # each 2-element row to unity norm -+ albetas = rng.uniform(low=-1.0, high=1.0, size=[nsteps, m, 2]) -+ aa = cnp.PyArray_DATA(albetas) -+ # Walk over every 2D row and normalize -+ for r in range(0, 2*nsteps*m, 2): -+ h = 1/hypot(aa[r], aa[r+1]) -+ aa[r] *= h -+ aa[r+1] *= h -+ -+ # idd_random_transf -+ rta = a.copy() -+ -+ # Rotate and shuffle "a" nsteps-many times -+ giv2x2 = cnp.PyArray_ZEROS(2, [2, 2], cnp.NPY_FLOAT64, 0) -+ for nstep in range(nsteps): -+ for row in range(m-1): -+ alpha, beta = albetas[nstep, row, 0], albetas[nstep, row, 1] -+ giv2x2[0, 0] = alpha -+ giv2x2[0, 1] = beta -+ giv2x2[1, 0] = -beta -+ giv2x2[1, 1] = alpha -+ np.matmul(giv2x2, rta[row:row+2, :], out=rta[row:row+2, :]) -+ -+ rta = rta[rng.permutation(m), :] -+ -+ # idd_subselect pick randomly n2-many rows -+ subselect = rng.choice(m, n2, replace=False) -+ rta = rta[subselect, :] -+ -+ # Perform rfft on each column. Note that the first and the last -+ # element of the result is real valued (n2 is power of 2). -+ # -+ # We view the complex valued entries as two consecutive doubles -+ # (by also removing the 2nd and last all-0 rows -- see idd_frm). -+ # Then after transpose we do a final row shuffle after transpose. -+ Fc = rfft(rta.T, axis=1) -+ # Move the first col to second col -+ Fc[:, 0] *= 1.j -+ # Perform the final permutation -+ F = Fc.view(np.float64)[:, 1:-1].T[rng.permutation(n2), :] -+ -+ Fcopy = F.copy() -+ cols = F.shape[1] -+ row = F.shape[0] -+ sssmax = 0. -+ ff = cnp.PyArray_DATA(F) -+ for r in range(cols): -+ h = dnrm2(&row, &ff[r], &cols) -+ if h > sssmax: -+ sssmax = h -+ -+ tau_arr = cnp.PyArray_ZEROS(1, [cols], cnp.NPY_FLOAT64, 0) -+ k, nulls = 0, 0 -+ -+ # In Fortran id_dist, F is transposed and works on the columns -+ # Since we have a C-array we work directly on rows -+ # The reflectors are overwritten on rows of F directly -+ # Hence at any k'th step, we have -+ # -+ # [ B r r r r r r r ] -+ # [ .... ] -+ # [ .... ] -+ # [ x x x B r r r r ] -+ # [ x x x x B r r r ] -+ # [ x x x x x B r r ] -+ # [ x x x x x x x x ] -+ # [ x x x x x x x x ] -+ # -+ -+ # Loop until nulls = 7, or krank+nulls = n2, or krank+nulls = n. -+ Fmemview = F -+ while (nulls < 7) and (k+nulls < min(n, n2)): -+ # Apply previous Householder reflectors -+ if k > 0: -+ for kk in range(k): -+ F[k, kk:] -= tau_arr[kk]*(F[kk, kk:] @ F[k, kk:])*F[kk, kk:] -+ -+ # Get the next Householder reflector and store in F -+ r = cols-k -+ # n, alpha, x, incx, tau -+ dlarfgp(&r, &Fmemview[k, k], &Fmemview[k, k+1], &intone, &tau_arr[k]) -+ beta = F[k, k] -+ F[k, k] = 1 -+ -+ if (beta <= eps*sssmax): -+ nulls += 1 -+ k += 1 -+ -+ if nulls < 7: -+ k = 0 -+ -+ return k, Fcopy -+ -+ -+def idd_findrank(A: LinearOperator, cnp.float64_t eps, rng=None): -+ # Estimate the rank of A by repeatedly using A.rmatvec(random vec) -+ -+ cdef int m = A.shape[0], n = A.shape[1], k = 0, kk = 0,r = n, krank -+ cdef int no_of_cols = 4, intone = 1, info = 0 -+ cdef cnp.float64_t[::1] tau = cnp.PyArray_ZEROS(1, [min(m, n)], cnp.NPY_FLOAT64, 0) -+ cdef cnp.float64_t[::1] y = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] retarr -+ -+ # The size of the QR decomposition is rank dependent which is unknown -+ # at runtime. Hence we don't want to allocate a dense version of the -+ # linear operator which can be too big. Instead, a typical "realloc double -+ # if run out of space" strategy is used here. Starts with 4*n -+ # Also, we hold the A.T @ x results in a separate array to return -+ # and do the same for that too. -+ cdef cnp.float64_t *ra = PyMem_Malloc( -+ sizeof(cnp.float64_t)*no_of_cols*n -+ ) -+ cdef cnp.float64_t *reallocated_ra -+ cdef cnp.float64_t *ret = PyMem_Malloc( -+ sizeof(cnp.float64_t)*no_of_cols*n -+ ) -+ cdef cnp.float64_t *reallocated_ret -+ cdef cnp.float64_t enorm = 0.0 -+ -+ if (not ra) or (not ret): -+ raise MemoryError("Failed to allocate at least required memory " -+ f"{no_of_cols*n*8} bytes for" -+ "'scipy.linalg.interpolative.idd_findrank()' " -+ "function.") -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ krank = 0 -+ try: -+ while True: -+ -+ # Generate random vector and rmatvec then save the result -+ x = rng.uniform(size=m) -+ y = A.rmatvec(x) -+ for kk in range(n): -+ ret[krank*n + kk] = y[kk] -+ -+ if krank == 0: -+ enorm = dnrm2(&n, &y[0], &intone) -+ else: # krank > 0 -+ # Transpose-Apply previous Householder reflectors, if any -+ # SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO -+ dorm2r('L','T', &n, &intone, &krank, &ra[0], &n, -+ &tau[0], &y[0], &n, &ra[(no_of_cols-1)*n], &info) -+ -+ # Get the next Householder reflector -+ r = n-krank -+ # N, ALPHA, X, INCX, TAU -+ dlarfgp(&r, &y[krank], &y[krank+1], &intone, &tau[krank]) -+ -+ for kk in range(n): -+ ra[krank*n + kk] = y[kk] -+ -+ # Running out of space; try to double the size of ra -+ if krank == (no_of_cols-2): -+ reallocated_ra = PyMem_Realloc( -+ ra, sizeof(cnp.float64_t)*no_of_cols*n*2) -+ reallocated_ret = PyMem_Realloc( -+ ret, sizeof(cnp.float64_t)*no_of_cols*n*2) -+ -+ if reallocated_ra and reallocated_ret: -+ ra = reallocated_ra -+ ret = reallocated_ret -+ no_of_cols *= 2 -+ else: -+ raise MemoryError( -+ "'scipy.linalg.interpolative.idd_findrank()' failed to " -+ f"allocate the required memory,{no_of_cols*n*16} bytes " -+ "while trying to determine the rank (currently " -+ f"{krank}) of a LinearOperator with precision {eps}." -+ ) -+ krank += 1 -+ if (y[krank-1] < eps*enorm) or (krank >= min(m, n)): -+ break -+ finally: -+ # Crashed or successfully ended up here -+ # Discard Householder vectors -+ PyMem_Free(ra) -+ retarr = cnp.PyArray_EMPTY(2, [krank, n], cnp.NPY_FLOAT64, 0) -+ for k in range(krank): -+ for kk in range(n): -+ retarr[k, kk] = ret[k*n+kk] -+ PyMem_Free(ret) -+ -+ return krank, retarr -+ -+ -+def idd_id2svd( -+ cnp.ndarray[cnp.float64_t, mode='c', ndim=2] cols, -+ cnp.ndarray[cnp.int64_t, mode='c', ndim=1] perms, -+ cnp.ndarray[cnp.float64_t, ndim=2] proj, -+ ): -+ cdef int m = cols.shape[0], krank = cols.shape[1] -+ cdef int n = proj.shape[1] + krank, info, ci -+ cdef cnp.ndarray[cnp.float64_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau1 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] S -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] V -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] VV -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds1 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] p -+ -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_FLOAT64, 0) -+ VV = cnp.PyArray_ZEROS(2, [n, krank], cnp.NPY_FLOAT64, 0) -+ p = cnp.PyArray_ZEROS(2, [krank, n], cnp.NPY_FLOAT64, 0) -+ -+ # idd_reconint -+ for ci in range(krank): -+ p[ci, perms[ci]] = 1.0 -+ -+ p[:, perms[krank:]] = proj[:, :] -+ -+ inds1, tau1 = iddr_qrpiv(cols, krank) -+ # idd_rinqr and idd_rearr -+ r = np.triu(cols[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r[:, [ci, inds1[ci]]] = r[:, [inds1[ci], ci]] -+ -+ t = p.T.copy() -+ inds2, tau2 = iddr_qrpiv(t, krank) -+ r2 = np.triu(t[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r2[:, [ci, inds2[ci]]] = r2[:, [inds2[ci], ci]] -+ -+ r3 = r @ r2.T -+ UU[:krank, :krank], S, V = la.svd(r3, -+ full_matrices=False, -+ check_finite=False) -+ -+ # Apply Q of col to U from the left, use cols as scratch -+ C = cols[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &m, &krank, &C[0, 0], &m, &tau1[0], -+ &UU[0,0], &krank, &cols[0, 0], &info) -+ -+ VV[:krank, :krank] = V[:, :].T -+ # Apply Q of t to V from the left -+ C = t[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &n, &krank, &C[0, 0], &n, &tau2[0], -+ &VV[0, 0], &krank, &cols[0, 0], &info) -+ -+ return UU, S, VV -+ -+ -+cdef inline int idd_ldiv(int l, int n) noexcept nogil: -+ cdef int m = l -+ while (n % m != 0): -+ m -= 1 -+ return m -+ -+ -+cdef int idd_poweroftwo(int m) noexcept nogil: -+ """ -+ Find the integer solution to l = floor(log2(m)) -+ """ -+ cdef int n = 1 -+ while (n < m): -+ n <<= 1 # Times 2 -+ return n >> 1 # Divide by 2 -+ -+ -+def idd_reconid(B, idx, proj): -+ cdef int m = B.shape[0], krank = B.shape[1] -+ cdef int n = len(idx) -+ approx = np.zeros([m, n], dtype=np.float64) -+ -+ approx[:, idx[:krank]] = B -+ approx[:, idx[krank:]] = B @ proj -+ -+ return approx -+ -+ -+def idd_snorm(A: LinearOperator, int its=20, rng=None): -+ cdef int n = A.shape[1] -+ cdef int j = 0, intone = 1 -+ cdef cnp.float64_t snorm = 0.0 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] v -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] u -+ -+ if not rng: -+ rng = np.random.default_rng() -+ v = rng.uniform(low=-1., high=1., size=n) -+ v /= dnrm2(&n, &v[0], &intone) -+ -+ for j in range(its): -+ u = A.matvec(v) -+ v = A.rmatvec(u) -+ snorm = dnrm2(&n, &v[0], &intone) -+ if snorm > 0.0: -+ v /= snorm -+ -+ snorm = np.sqrt(snorm) -+ -+ return snorm -+ -+ -+def iddp_aid(cnp.ndarray[cnp.float64_t, ndim=2] a: NDArray, eps: float, rng=None): -+ krank, proj = idd_estrank(a, eps, rng=rng) -+ if krank != 0: -+ proj = proj[:krank, :] -+ return iddp_id(proj, eps=eps) -+ -+ return iddp_id(a, eps=eps) -+ -+ -+def iddp_asvd(cnp.ndarray[cnp.float64_t, ndim=2] a: NDArray, eps: float, rng=None): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef int krank, info, ci -+ cdef cnp.ndarray[cnp.float64_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau1 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] S -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] V -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] VV -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] perms -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds1 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] p -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] col -+ -+ krank, perms, proj = iddp_aid(a.copy(), eps, rng=rng) -+ -+ if krank > 0: -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_FLOAT64, 0) -+ VV = cnp.PyArray_ZEROS(2, [n, krank], cnp.NPY_FLOAT64, 0) -+ -+ p = cnp.PyArray_ZEROS(2, [krank, n], cnp.NPY_FLOAT64, 0) -+ col = a[:, perms[:krank]].copy() -+ -+ # idd_reconint -+ for ci in range(krank): -+ p[ci, perms[ci]] = 1.0 -+ -+ # p[np.arange(krank), perms[:krank]] = 1. -+ p[:, perms[krank:]] = proj[:, :] -+ -+ inds1, tau1 = iddr_qrpiv(col, krank) -+ # idd_rinqr and idd_rearr -+ r = np.triu(col[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r[:, [ci, inds1[ci]]] = r[:, [inds1[ci], ci]] -+ -+ t = p.T.copy() -+ inds2, tau2 = iddr_qrpiv(t, krank) -+ r2 = np.triu(t[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r2[:, [ci, inds2[ci]]] = r2[:, [inds2[ci], ci]] -+ -+ r3 = r @ r2.T -+ UU[:krank, :krank], S, V = la.svd(r3, full_matrices=False) -+ -+ # Apply Q of col to U from the left -+ C = col[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &m, &krank, &C[0, 0], &m, &tau1[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ VV[:krank, :krank] = V[:, :].T -+ # Apply Q of t to V from the left -+ C = t[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &n, &krank, &C[0, 0], &n, &tau2[0], -+ &VV[0, 0], &krank, &a[0, 0], &info) -+ -+ return UU, S, VV -+ -+ -+def iddp_id(cnp.ndarray[cnp.float64_t, ndim=2] a: NDArray, eps: float): -+ cdef int n = a.shape[1], krank, tmp_int, p -+ cdef cnp.float64_t one = 1 -+ krank, _, inds = iddp_qrpiv(a, eps) -+ -+ # Change pivots to permutation -+ perms = cnp.PyArray_ZEROS(1, [n], cnp.NPY_INT64, 0) -+ for p in range(n): -+ perms[p] = p -+ -+ if krank > 0: -+ for p in range(krank): -+ # Apply pivots -+ tmp_int = perms[p] -+ perms[p] = perms[inds[p]] -+ perms[inds[p]] = tmp_int -+ # perms[[p, inds[p]]] = perms[[inds[p], p]] -+ -+ # Let A = [A1, A2] and A1 has krank cols and upper triangular. -+ # Find X that satisfies A1 @ X = A2 -+ # In SciPy.linalg this amounts to; -+ # -+ # proj = la.solve_triangular(a[:krank, :krank], a[:krank, krank:], -+ # lower=False, check_finite=False) -+ # -+ # Push into BLAS without transposes. -+ # A1 = a[:krank, :krank] -+ # A2 = a[:krank, krank:] -+ # Instead solve X @ A1.T = A2.T -+ # Fortran already sees A1 as A1.T and becomes lower tri, side = R -+ -+ tmp_int = n - krank -+ # SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB -+ dtrsm('R', 'L', 'N', 'N', -+ &tmp_int, &krank, &one, &a[0, 0], &n, &a[0, krank], &n) -+ -+ return krank, np.array(perms), a[:krank, krank:] -+ -+ -+def iddp_qrpiv(cnp.ndarray[cnp.float64_t, mode="c", ndim=2] a, cnp.float64_t eps): -+ """ -+ This is a minimal version of ?GEQP3 from LAPACK with an -+ additional early stopping criterion over given precision. -+ -+ This function overwrites entries of "a" ! -+ """ -+ -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef cnp.ndarray col_norms = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ cdef int k = 0, kpiv = 0, i = 0, tmp_int = 0, int_n = 0 -+ cdef cnp.float64_t tmp_sca = 0. -+ cdef cnp.ndarray taus = cnp.PyArray_ZEROS(1, [m], cnp.NPY_FLOAT64, 0) -+ cdef cnp.ndarray ind = cnp.PyArray_ZEROS(1, [n], cnp.NPY_INT64, 0) -+ cdef cnp.float64_t[::1] taus_v = taus -+ cdef cnp.float64_t feps = 0.1e-16 # np.finfo(np.float64).eps -+ cdef cnp.float64_t ssmax, ssmaxin -+ cdef int nupdate = 0 -+ -+ for i in range(n): -+ col_norms[i] = dnrm2(&m, &a[0, i], &n)**2 -+ -+ kpiv = np.argmax(col_norms) -+ ssmax = col_norms[kpiv] -+ ssmaxin = ssmax -+ -+ for k in range(min(m, n)): -+ -+ # Pivoting -+ ind[k] = kpiv -+ # Swap columns a[:, k] and a[:, kpiv] -+ a[:, [kpiv, k]] = a[:, [k, kpiv]] -+ -+ # Swap col_norms[krank] and col_norms[kpiv] -+ col_norms[[kpiv, k]] = col_norms[[k, kpiv]] -+ -+ if k < m-1: -+ # Compute the householder reflector for column k -+ tmp_sca = a[k, k] -+ # FIX: Convert these to F_INT -+ tmp_int = (m - k) -+ int_n = n -+ dlarfgp(&tmp_int, &tmp_sca, &a[k+1, k], &int_n, &taus_v[k]) -+ -+ # Overwrite with 1. for easy matmul -+ a[k, k] = 1 -+ if k < n-1: -+ # Apply the householder reflector to the rest on the right -+ a[k:, k+1:] -= np.outer(taus[k]*a[k:, k], a[k:, k] @ a[k:, k+1:]) -+ -+ # Put back the beta in place -+ a[k, k] = tmp_sca -+ -+ # Update the norms -+ col_norms[k] = 0 -+ col_norms[k+1:] -= a[k, k+1:]**2 -+ ssmax = 0 -+ kpiv = k+1 -+ if k < n-1: -+ kpiv = np.argmax(col_norms[k+1:]) + (k + 1) -+ ssmax = col_norms[kpiv] -+ -+ if (((ssmax < 1000*feps*ssmaxin) and (nupdate == 0)) or -+ ((ssmax < ((1000*feps)**2)*ssmaxin) and (nupdate == 1))): -+ nupdate += 1 -+ ssmax = 0 -+ kpiv = k+1 -+ -+ if k < n-1: -+ for i in range(k+1, n): -+ tmp_int = m-k-1 -+ col_norms[i] = dnrm2(&tmp_int, &a[k+1, i], &n)**2 -+ kpiv = np.argmax(col_norms[k+1:]) + (k + 1) -+ ssmax = col_norms[kpiv] -+ if (ssmax <= (eps**2)*ssmaxin): -+ break -+ # a is overwritten; return numerical rank and pivots -+ return k + 1, taus, ind -+ -+ -+def iddp_rid(A: LinearOperator, cnp.float64_t eps, rng=None): -+ _, ret = idd_findrank(A, eps, rng) -+ return iddp_id(ret, eps) -+ -+ -+def iddp_rsvd(A: LinearOperator, cnp.float64_t eps, rng=None): -+ cdef int n = A.shape[1] -+ cdef int krank, j -+ cdef cnp.ndarray[cnp.int64_t, mode='c', ndim=1] perms -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] col -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] x -+ -+ krank, perms, proj = iddp_rid(A, eps, rng) -+ if krank > 0: -+ # idd_getcols -+ col = cnp.PyArray_EMPTY(2, [n, krank], cnp.NPY_FLOAT64, 0) -+ x = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ -+ for j in range(krank): -+ x[perms[j]] = 1. -+ col[:, j] = A.matvec(x) -+ x[perms[j]] = 0. -+ -+ return idd_id2svd(cols=col, perms=perms, proj=proj) -+ -+ # TODO: figure out empty return -+ return None -+ -+ -+def iddp_svd(cnp.ndarray[cnp.float64_t, ndim=2] a: NDArray, eps: float): -+ """a is overwritten""" -+ cdef int m = a.shape[0], krank, info -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] taus -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='fortran', ndim=2] C -+ -+ # Get the pivoted QR -+ krank, taus, inds = iddp_qrpiv(a, eps) -+ -+ if krank > 0: -+ r = np.triu(a[:krank, :]) -+ # Apply pivots in reverse -+ for p in range(krank-1, -1, -1): -+ r[:, [p, inds[p]]] = r[:, [inds[p], p]] -+ -+ # JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO -+ # dgesvd('S', 'O', &krank, &n) -+ U, S, V = la.svd(r, full_matrices=False) -+ -+ # Apply Q to U via dorm2r -+ # Possibly U is shorter than Q -+ UU = np.zeros([m, krank], dtype=a.dtype) -+ UU[:krank, :krank] = U -+ # Do the transpose dance for C-layout, use a for scratch -+ C = a[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &m, &krank, &C[0, 0], &m, &taus[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ return UU, S, V -+ -+ -+def iddr_aid(cnp.ndarray[cnp.float64_t, mode="c", ndim=2] a: NDArray, int krank, -+ rng=None): -+ cdef int m = a.shape[0], n = a.shape[1], n2, nsteps = 3, row, r, nstep, L -+ cdef cnp.float64_t h, alpha, beta -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=3] albetas -+ cdef cnp.ndarray[cnp.npy_int64, mode='c', ndim=1] subselect -+ cdef cnp.float64_t *aa -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] giv2x2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] rta -+ cdef cnp.ndarray[cnp.npy_int64, mode='c', ndim=1] marker -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ # idd_aidi -+ L = krank + 8 -+ n2 = 0 -+ if (L >= n2) or (L > m): -+ inds, proj = iddr_id(a, krank) -+ return inds, proj -+ -+ n2 = idd_poweroftwo(m) -+ -+ # idd_sfrmi -+ # idd_pairsamps -+ ind = rng.permutation(n2) -+ ind2 = cnp.PyArray_ZEROS(1, [L], cnp.NPY_INT64, 0) -+ -+ marker = cnp.PyArray_ZEROS(1, [n2//2], cnp.NPY_INT64, 0) -+ for k in range(L): -+ marker[(ind[k]+1)//2] = marker[(ind[k]+1)//2]+1 -+ -+ for r in range(n2//2): -+ if marker[r] != 0: -+ l2 += 1 -+ ind2[r] = r -+ -+ # Draw (nsteps x m x 2) arrays from [-1, 1) uniformly and scale -+ # each 2-element row to unity norm -+ albetas = rng.uniform(low=-1.0, high=1.0, size=[nsteps, m, 2]) -+ aa = cnp.PyArray_DATA(albetas) -+ # Walk over every 2D row and normalize -+ for r in range(0, 2*nsteps*m, 2): -+ # ignoring the improbable zero generation by rng.uniform -+ h = 1.0/hypot(aa[r], aa[r+1]) -+ aa[r] *= h -+ aa[r+1] *= h -+ -+ # idd_random_transf -+ rta = a.copy() -+ -+ # Rotate and shuffle "a" nsteps-many times -+ giv2x2 = cnp.PyArray_ZEROS(2, [2, 2], cnp.NPY_FLOAT64, 0) -+ for nstep in range(nsteps): -+ for row in range(m-1): -+ alpha, beta = albetas[nstep, row, 0], albetas[nstep, row, 1] -+ giv2x2[0, 0] = alpha -+ giv2x2[0, 1] = beta -+ giv2x2[1, 0] = -beta -+ giv2x2[1, 1] = alpha -+ np.matmul(giv2x2, rta[row:row+2, :], out=rta[row:row+2, :]) -+ -+ rta = rta[rng.permutation(m), :] -+ -+ # idd_subselect pick randomly n2-many rows -+ subselect = rng.choice(m, n2, replace=False) -+ rta = rta[subselect, :] -+ -+ # idd_sffti -+ twopi = 2*np.pi -+ twopii = twopi*1.j -+ nblock = idd_ldiv(l2, n2) -+ fact = 1/np.sqrt(n2) -+ -+ if l2 == 1: -+ wsave = np.exp(-twopii*k*ind2[0]/np.arange(1, n2+1))*fact -+ else: -+ m = n2//nblock -+ -+ wsave = np.empty(m*l2, dtype=complex) -+ for j in range(l2): -+ i = ind2[j] -+ if (i+1) <= (n//2 - m//2): -+ idivm = i // m -+ imodm = i - m*idivm -+ for k in range(m): -+ wsave[m*j+k] = ( -+ np.exp(-twopii*(k)*imodm/m)* -+ np.exp(-twopii*(k)*(idivm+1)/n)* -+ fact -+ ) -+ else: -+ idivm = (i+1)//(m//2) -+ imodm = (i+1)-(m//2)*idivm -+ for k in range(m): -+ wsave[m*j+k] = np.exp(-twopii*(k-1)*imodm/m)*fact -+ -+ # idd_sfft.f -+ # There is some significant index olympics happening in the original Fortran code -+ # however I could not reverse engineer it to understand what is happening and kept -+ # as is with all its cryptic movements and their performance hits. -+ # See DOI:10.1016/j.acha.2007.12.002 - Section 3.3 -+ -+ # Perform partial FFT to each nblock -+ F = rfft(rta.reshape(nblock, m, -1), order='F', axis=0) -+ # Roll the first entry to the last in the first axis for -+ # the real frequency components. (faster than np.roll) -+ F = F[[x for x in range(1, F.shape[0])] + [0], :, :] -+ # Convert back to 2D array -+ F = F.reshape(F.shape[0]*F.shape[1], -1) -+ -+ csum = np.zeros_like(F[0, :]) -+ rsum = np.zeros_like(F[0, :]) -+ -+ for j in range(l2): -+ i = ind2[j] -+ if (i+1) <= (n//2 - m//2): -+ idivm = i // m -+ imodm = i - m*idivm -+ csum[:] = 0.0 -+ for k in range(m): -+ csum += F[m*idivm+k, :] * wsave[m*j+k] -+ rta[2*i, :] = csum.real -+ rta[2*i+1, :] = csum.imag -+ -+ else: -+ idivm = (i+1)//(m//2) -+ imodm = (i+1)-(m//2)*idivm -+ csum[:] = 0.0 -+ for k in range(m): -+ csum += F[m*(nblock//2)+k, :] * wsave[m*j+k] -+ rta[2*i, :] = csum.real -+ rta[2*i+1, :] = csum.imag -+ if i == (n//2) - 1: -+ for k in range(m): -+ rsum += F[m*(nblock//2)+k, :] -+ rta[n-2, :] = rsum -+ rta[n-2, :] *= fact -+ -+ rsum[:] = 0.0 -+ for k in range(m//2): -+ rsum += F[m*(nblock//2)+2*k-1] -+ rsum -= F[m*(nblock//2)+2*k] -+ rta[n-1, :] = rsum -+ rta[n-1, :] *= fact -+ -+ # idd_subselect pick randomly l2-many rows -+ subselect = rng.choice(n2, l2, replace=False) -+ rta = rta[subselect, :] -+ -+ perms, proj = iddr_id(rta, krank) -+ -+ return perms, proj -+ -+ -+def iddr_asvd(cnp.ndarray[cnp.float64_t, mode="c", ndim=2] a: NDArray, int krank, -+ rng=None): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef int info, ci -+ cdef cnp.ndarray[cnp.float64_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau1 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] tau2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] S -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] V -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] VV -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] perms -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds1 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds2 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] p -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] col -+ -+ perms, proj = iddr_aid(a.copy(), krank=krank, rng=rng) -+ -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_FLOAT64, 0) -+ VV = cnp.PyArray_ZEROS(2, [n, krank], cnp.NPY_FLOAT64, 0) -+ -+ p = cnp.PyArray_ZEROS(2, [krank, n], cnp.NPY_FLOAT64, 0) -+ col = a[:, perms[:krank]].copy() -+ -+ # idd_reconint -+ for ci in range(krank): -+ p[ci, perms[ci]] = 1.0 -+ -+ p[:, perms[krank:]] = proj[:, :] -+ -+ inds1, tau1 = iddr_qrpiv(col, krank) -+ # idd_rinqr and idd_rearr -+ r = np.triu(col[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r[:, [ci, inds1[ci]]] = r[:, [inds1[ci], ci]] -+ -+ t = p.T.copy() -+ inds2, tau2 = iddr_qrpiv(t, krank) -+ r2 = np.triu(t[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r2[:, [ci, inds2[ci]]] = r2[:, [inds2[ci], ci]] -+ -+ r3 = r @ r2.T -+ UU[:krank, :krank], S, V = la.svd(r3, full_matrices=False) -+ -+ # Apply Q of col to U from the left -+ C = col[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &m, &krank, &C[0, 0], &m, &tau1[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ VV[:krank, :krank] = V[:, :].T -+ # Apply Q of t to V from the left -+ C = t[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &n, &krank, &C[0, 0], &n, &tau2[0], -+ &VV[0, 0], &krank, &a[0, 0], &info) -+ -+ return UU, S, VV -+ -+ -+def iddr_id(cnp.ndarray[cnp.float64_t, ndim=2] a, int krank): -+ cdef int n = a.shape[1] -+ cdef int tmp_int -+ cdef cnp.float64_t one = 1.0 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] perms -+ -+ inds, _ = iddr_qrpiv(a, krank) -+ perms = cnp.PyArray_Arange(0, n, 1, cnp.NPY_INT64) -+ -+ if krank > 0: -+ for p in range(krank): -+ # Apply pivots -+ tmp_int = perms[p] -+ perms[p] = perms[inds[p]] -+ perms[inds[p]] = tmp_int -+ -+ # See iddp_id comments for below -+ tmp_int = n - krank -+ # SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB -+ dtrsm('R', 'L', 'N', 'N', -+ &tmp_int, &krank, &one, &a[0, 0], &n, &a[0, krank], &n) -+ -+ return perms, a[:krank, krank:] -+ -+ -+def iddr_qrpiv(cnp.ndarray[cnp.float64_t, mode="c", ndim=2] a: NDArray, krank: int): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef cnp.ndarray col_norms = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ cdef int loop = 0, loops, kpiv = 0, i = 0, tmp_int = 0, int_n = 0 -+ cdef cnp.float64_t tmp_sca = 0. -+ cdef cnp.ndarray taus = cnp.PyArray_ZEROS(1, [m], cnp.NPY_FLOAT64, 0) -+ cdef cnp.ndarray ind = cnp.PyArray_ZEROS(1, [n], cnp.NPY_INT64, 0) -+ cdef cnp.float64_t[::1] taus_v = taus -+ cdef cnp.float64_t feps = 0.1e-16 # np.finfo(np.float64).eps -+ cdef cnp.float64_t ssmax, ssmaxin -+ cdef int nupdate = 0 -+ -+ loops = min(krank, min(m, n)) -+ for i in range(n): -+ col_norms[i] = dnrm2(&m, &a[0, i], &n)**2 -+ -+ kpiv = np.argmax(col_norms) -+ ssmax = col_norms[kpiv] -+ ssmaxin = ssmax -+ -+ for loop in range(loops): -+ -+ ind[loop] = kpiv -+ # Swap columns a[:, k] and a[:, kpiv] -+ a[:, [kpiv, loop]] = a[:, [loop, kpiv]] -+ # Swap col_norms[krank] and col_norms[kpiv] -+ col_norms[[kpiv, loop]] = col_norms[[loop, kpiv]] -+ -+ if loop < m-1: -+ tmp_sca = a[loop, loop] -+ # FIX: Convert these to F_INT -+ tmp_int = (m - loop) -+ int_n = n -+ dlarfgp(&tmp_int, &tmp_sca, &a[loop+1, loop], &int_n, &taus_v[loop]) -+ -+ # Overwrite with 1. for easy matmul -+ a[loop, loop] = 1 -+ if loop < n-1: -+ # Apply the householder reflector to the rest on the right -+ a[loop:, loop+1:] -= np.outer(taus[loop]*a[loop:, loop], -+ a[loop:, loop] @ a[loop:, loop+1:]) -+ -+ # Put back the beta in place -+ a[loop, loop] = tmp_sca -+ -+ # Update the norms -+ col_norms[loop] = 0 -+ col_norms[loop+1:] -= a[loop, loop+1:]**2 -+ ssmax = 0 -+ kpiv = loop+1 -+ -+ if loop < n-1: -+ kpiv = np.argmax(col_norms[loop+1:]) + (loop + 1) -+ ssmax = col_norms[kpiv] -+ if (((ssmax < 1000*feps*ssmaxin) and (nupdate == 0)) or -+ ((ssmax < ((1000*feps)**2)*ssmaxin) and (nupdate == 1))): -+ nupdate += 1 -+ ssmax = 0 -+ kpiv = loop+1 -+ -+ if loop < n-1: -+ for i in range(loop+1, n): -+ tmp_int = m-loop-1 -+ col_norms[i] = dnrm2(&tmp_int, &a[loop+1, i], &n)**2 -+ kpiv = np.argmax(col_norms[loop+1:]) + (loop + 1) -+ ssmax = col_norms[kpiv] -+ -+ return ind, taus -+ -+ -+def iddr_rid(A: LinearOperator, int krank, rng=None): -+ cdef int m = A.shape[0], n = A.shape[1], k = 0 -+ cdef int L = min(krank+2, min(m, n)) -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] r -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ r = cnp.PyArray_EMPTY(2, [L, n], cnp.NPY_FLOAT64, 0) -+ for k in range(L): -+ r[k, :] = A.rmatvec(rng.uniform(size=m)) -+ -+ return iddr_id(a=r, krank=krank) -+ -+ -+def iddr_rsvd(A: LinearOperator, int krank, rng=None): -+ cdef int n = A.shape[1], j -+ cdef cnp.ndarray[cnp.int64_t, mode='c', ndim=1] perms -+ cdef cnp.ndarray[cnp.float64_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] col -+ -+ perms, proj = iddr_rid(A, krank, rng) -+ # idd_getcols -+ col = cnp.PyArray_EMPTY(2, [n, krank], cnp.NPY_FLOAT64, 0) -+ x = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ for j in range(krank): -+ x[perms[j]] = 1. -+ col[:, j] = A.matvec(x) -+ x[perms[j]] = 0. -+ -+ return idd_id2svd(cols=col, perms=perms, proj=proj) -+ -+ -+def iddr_svd(cnp.ndarray[cnp.float64_t, mode="c", ndim=2] a: NDArray, int krank): -+ cdef int m = a.shape[0], info = 0 -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] taus -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='fortran', ndim=2] C -+ -+ # Get the pivoted QR -+ inds, taus = iddr_qrpiv(a, krank) -+ -+ r = np.triu(a[:krank, :]) -+ # Apply pivots in reverse -+ for p in range(krank-1, -1, -1): -+ r[:, [p, inds[p]]] = r[:, [inds[p], p]] -+ -+ # JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO -+ # dgesvd('S', 'O', &krank, &n) -+ U, S, V = la.svd(r, full_matrices=False) -+ -+ # Apply Q to U via dorm2r -+ # Possibly U is shorter than Q -+ UU = np.zeros([m, krank], dtype=a.dtype) -+ UU[:krank, :krank] = U -+ # Do the transpose dance for C-layout, use a for scratch -+ C = a[:, :krank].copy(order='F') -+ dorm2r('R', 'T', -+ &krank, &m, &krank, &C[0, 0], &m, &taus[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ return UU, S, V -+ -+ -+def idz_diffsnorm(A: LinearOperator, B: LinearOperator, int its=20, rng=None): -+ cdef int n = A.shape[1], j = 0, intone = 1 -+ cdef cnp.float64_t snorm = 0.0 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] v1 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] v2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] u1 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] u2 -+ -+ if not rng: -+ rng = np.random.default_rng() -+ v1 = rng.uniform(low=-1, high=1, size=(n, 2)).view(np.complex128).ravel() -+ v1 /= dznrm2(&n, &v1[0], &intone) -+ -+ for j in range(its): -+ u1 = A.matvec(v1) -+ u2 = B.matvec(v1) -+ u1 -= u2 -+ v1 = A.rmatvec(u1) -+ v2 = B.rmatvec(u1) -+ v1 -= v2 -+ -+ snorm = dznrm2(&n, &v1[0], &intone) -+ if snorm > 0.0: -+ v1 /= snorm -+ -+ snorm = np.sqrt(snorm) -+ -+ return snorm -+ -+ -+def idz_estrank(cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] a: NDArray, eps: float, -+ rng=None): -+ cdef int m = a.shape[0], n = a.shape[1], n2, nsteps = 3, row, r, nstep, cols, k -+ cdef cnp.float64_t h, alpha, beta -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=3] albetas -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau_arr -+ cdef cnp.ndarray[cnp.npy_int64, mode='c', ndim=1] subselect -+ cdef double complex[:, ::1] ff -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=2] giv2x2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] rta -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] F -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ n2 = idd_poweroftwo(m) -+ # This part is the initialization that is done via idz_frmi -+ # for a Subsampled Randomized Fourier Transfmrom (SRFT). -+ -+ # Draw (nsteps x m x 4) array from [0, 2)*pi uniformly for -+ # random points on complex unit circle and unitary rotations -+ albetas = np.empty([nsteps, m, 4]) -+ albetas[:, :, 2:] = rng.uniform(low=0.0, high=2.0, size=[nsteps, m, 2]) -+ albetas[:, :, 2:] *= np.pi -+ np.cos(albetas[:, :, 2], out=albetas[:, :, 0]) -+ np.sin(albetas[:, :, 2], out=albetas[:, :, 1]) -+ np.cos(albetas[:, :, 3], out=albetas[:, :, 2]) -+ np.sin(albetas[:, :, 3], out=albetas[:, :, 3]) -+ -+ # idd_random_transf -+ rta = a.copy() -+ -+ # Rotate and shuffle "a" nsteps-many times -+ giv2x2 = cnp.PyArray_ZEROS(2, [2, 2], cnp.NPY_FLOAT64, 0) -+ for nstep in range(nsteps): -+ # Multiply with a point on the unit circle -+ rta *= albetas[nstep, :, 2:].view(np.complex128) -+ # Rotate -+ for row in range(m-1): -+ alpha, beta = albetas[nstep, row, 0], albetas[nstep, row, 1] -+ giv2x2[0, 0] = alpha -+ giv2x2[0, 1] = beta -+ giv2x2[1, 0] = -beta -+ giv2x2[1, 1] = alpha -+ np.matmul(giv2x2, rta[row:row+2, :], out=rta[row:row+2, :]) -+ -+ rta = rta[rng.permutation(m), :] -+ -+ # idd_subselect pick randomly n2-many rows -+ subselect = rng.choice(m, n2, replace=False) -+ rta = rta[subselect, :] -+ # Perform rfft on each column. -+ F = fft(rta, axis=0)[rng.permutation(n2), :] -+ -+ Fcopy = F.copy() -+ cols = F.shape[1] -+ row = F.shape[0] -+ sssmax = 0. -+ -+ for r in range(cols): -+ h = dznrm2(&row, &F[0, r], &cols) -+ if h > sssmax: -+ sssmax = h -+ -+ tau_arr = cnp.PyArray_ZEROS(1, [cols], cnp.NPY_COMPLEX128, 0) -+ k, nulls = 0, 0 -+ ff = F -+ # Loop until nulls = 7, or krank+nulls = n2, or krank+nulls = n. -+ while (nulls < 7) and (k+nulls < min(n, n2)): -+ # Apply previous Householder reflectors -+ if k > 0: -+ for kk in range(k): -+ F[k, kk:] -= ( -+ np.conj(tau_arr[kk])* -+ (F[kk, kk:].conj() @ F[k, kk:])* -+ F[kk, kk:] -+ ) -+ -+ # Get the next Householder reflector and store in F -+ r = cols-k -+ row = 1 -+ zlarfgp(&r, &ff[k, k], &ff[k, k+1], &row, &tau_arr[k]) -+ if (np.abs(F[k, k]) <= eps*sssmax): -+ nulls += 1 -+ F[k, k] = 1 -+ k += 1 -+ -+ if nulls < 7: -+ k = 0 -+ -+ return k, Fcopy -+ -+ -+def idz_findrank(A: LinearOperator, cnp.float64_t eps, rng=None): -+ # Estimate the rank of A by repeatedly using A.rmatvec(random vec) -+ -+ cdef int m = A.shape[0], n = A.shape[1], k = 0, kk = 0,r = n, krank -+ cdef int no_of_cols = 4, intone = 1, info = 0 -+ cdef cnp.complex128_t[::1] tau = cnp.PyArray_ZEROS(1, [min(m, n)], -+ cnp.NPY_COMPLEX128, 0) -+ cdef cnp.complex128_t[::1] y = cnp.PyArray_ZEROS(1, [n], cnp.NPY_COMPLEX128, 0) -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] retarr -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] x -+ -+ # The size of the QR decomposition is rank dependent which is unknown -+ # at runtime. Hence we don't want to allocate a dense version of the -+ # linear operator which can be too big. Instead, a typical "realloc double -+ # if run out of space" strategy is used here. Starts with 4*n -+ # Also, we hold the A.T @ x results in a separate array to return -+ # and do the same for that too. -+ cdef cnp.complex128_t *ra = PyMem_Malloc( -+ sizeof(cnp.complex128_t)*no_of_cols*n -+ ) -+ cdef cnp.complex128_t *reallocated_ra -+ cdef cnp.complex128_t *ret = PyMem_Malloc( -+ sizeof(cnp.complex128_t)*no_of_cols*n -+ ) -+ cdef cnp.complex128_t *reallocated_ret -+ cdef cnp.complex128_t enorm = 0.0 -+ -+ if (not ra) or (not ret): -+ raise MemoryError("Failed to allocate at least required memory " -+ f"{no_of_cols*n*8} bytes for" -+ "'scipy.linalg.interpolative.idz_findrank()' " -+ "function.") -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ krank = 0 -+ try: -+ while True: -+ -+ # Generate random vector and rmatvec then save the result -+ x = rng.uniform(size=(m,2)).view(np.complex128).ravel() -+ y = A.rmatvec(x) -+ -+ for kk in range(n): -+ ret[krank*n + kk] = y[kk] -+ -+ if krank == 0: -+ enorm = dznrm2(&n, &y[0], &intone) -+ else: # krank > 0 -+ # Transpose-Apply previous Householder reflectors, if any -+ # SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO -+ zunm2r('L','C', &n, &intone, &krank, &ra[0], &n, -+ &tau[0], &y[0], &n, &ra[(no_of_cols-1)*n], &info) -+ -+ # Get the next Householder reflector -+ r = n-krank -+ # N, ALPHA, X, INCX, TAU -+ zlarfgp(&r, &y[krank], &y[krank+1], &intone, &tau[krank]) -+ -+ for kk in range(n): -+ ra[krank*n + kk] = y[kk] -+ -+ # Running out of space; try to double the size of ra -+ if krank == (no_of_cols-2): -+ reallocated_ra = PyMem_Realloc( -+ ra, sizeof(cnp.complex128_t)*no_of_cols*n*2) -+ reallocated_ret = PyMem_Realloc( -+ ret, sizeof(cnp.complex128_t)*no_of_cols*n*2) -+ -+ if reallocated_ra and reallocated_ret: -+ ra = reallocated_ra -+ ret = reallocated_ret -+ no_of_cols *= 2 -+ else: -+ raise MemoryError( -+ "'scipy.linalg.interpolative.idz_findrank()' failed to " -+ f"allocate the required memory,{no_of_cols*n*16} bytes " -+ "while trying to determine the rank (currently " -+ f"{krank}) of a LinearOperator with precision {eps}." -+ ) -+ krank += 1 -+ if (np.abs(y[krank-1]) < eps*enorm) or (krank >= min(m, n)): -+ break -+ finally: -+ # Crashed or successfully ended up here -+ # Discard Householder vectors -+ PyMem_Free(ra) -+ retarr = cnp.PyArray_EMPTY(2, [krank, n], cnp.NPY_COMPLEX128, 0) -+ for k in range(krank): -+ for kk in range(n): -+ retarr[k, kk] = ret[k*n+kk] -+ PyMem_Free(ret) -+ -+ return krank, retarr -+ -+ -+def idz_id2svd( -+ cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] cols, -+ cnp.ndarray[cnp.int64_t, mode='c', ndim=1] perms, -+ cnp.ndarray[cnp.complex128_t, ndim=2] proj, -+ ): -+ cdef int m = cols.shape[0], krank = cols.shape[1] -+ cdef int n = proj.shape[1] + krank, info, ci -+ cdef cnp.ndarray[cnp.complex128_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau1 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] S -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] V -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] VV -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds1 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] p -+ -+ if krank > 0: -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_COMPLEX128, 0) -+ VV = cnp.PyArray_ZEROS(2, [n, krank], cnp.NPY_COMPLEX128, 0) -+ p = cnp.PyArray_ZEROS(2, [krank, n], cnp.NPY_COMPLEX128, 0) -+ -+ # idd_reconint -+ for ci in range(krank): -+ p[ci, perms[ci]] = 1.0 -+ -+ p[:, perms[krank:]] = proj[:, :] -+ inds1, tau1 = idzr_qrpiv(cols, krank) -+ # idz_rinqr and idz_rearr -+ r = np.triu(cols[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r[:, [ci, inds1[ci]]] = r[:, [inds1[ci], ci]] -+ -+ t = p.T.conj().copy() -+ inds2, tau2 = idzr_qrpiv(t, krank) -+ r2 = np.triu(t[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r2[:, [ci, inds2[ci]]] = r2[:, [inds2[ci], ci]] -+ -+ r3 = r @ r2.T.conj() -+ UU[:krank, :krank], S, V = la.svd(r3, full_matrices=False) -+ -+ # Apply Q of col to U from the left -+ # But do the adjoint dance for LAPACK via U.H @ Q.H -+ np.conjugate(tau1, out=tau1) -+ C = cols[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &m, &krank, &C[0, 0], &m, &tau1[0], -+ &UU[0,0], &krank, &cols[0, 0], &info) -+ -+ VV[:krank, :krank] = V[:, :].conj().T -+ -+ # Apply Q of t to V from the left -+ # But do the adjoint dance for LAPACK via V.H @ Q.H -+ np.conjugate(tau2, out=tau2) -+ C = t[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &n, &krank, &C[0, 0], &n, &tau2[0], -+ &VV[0, 0], &krank, &cols[0, 0], &info) -+ -+ return UU, S, VV -+ -+ -+def idz_reconid(B, idx, proj): -+ cdef int m = B.shape[0], krank = B.shape[1] -+ cdef int n = len(idx) -+ approx = np.zeros([m, n], dtype=np.complex128) -+ -+ approx[:, idx[:krank]] = B -+ approx[:, idx[krank:]] = B @ proj -+ -+ return approx -+ -+ -+def idz_snorm(A: LinearOperator, int its=20, rng=None): -+ cdef int n = A.shape[1] -+ cdef int j = 0, intone = 1 -+ cdef cnp.float64_t snorm = 0.0 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] v -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] u -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ v = rng.uniform(low=-1, high=1, size=(n, 2)).view(np.complex128).ravel() -+ v /= dznrm2(&n, &v[0], &intone) -+ -+ for j in range(its): -+ u = A.matvec(v) -+ v = A.rmatvec(u) -+ snorm = dznrm2(&n, &v[0], &intone) -+ if snorm > 0.0: -+ v /= snorm -+ -+ snorm = np.sqrt(snorm) -+ -+ return snorm -+ -+ -+def idzp_aid(cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] a: NDArray, eps: float, -+ rng=None): -+ krank, proj = idz_estrank(a, eps=eps, rng=rng) -+ if krank != 0: -+ proj = proj[:krank, :] -+ return idzp_id(proj, eps=eps) -+ -+ return idzp_id(a, eps=eps) -+ -+ -+def idzp_asvd(cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] a, cnp.float64_t eps, -+ rng=None): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef int krank, info, ci -+ cdef cnp.ndarray[cnp.complex128_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau1 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] S -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] V -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] VV -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] perms -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds1 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] p -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] col -+ -+ krank, perms, proj = idzp_aid(a.copy(), eps, rng) -+ -+ if krank > 0: -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_COMPLEX128, 0) -+ VV = cnp.PyArray_ZEROS(2, [n, krank], cnp.NPY_COMPLEX128, 0) -+ p = cnp.PyArray_ZEROS(2, [krank, n], cnp.NPY_COMPLEX128, 0) -+ col = a[:, perms[:krank]].copy() -+ -+ # idd_reconint -+ for ci in range(krank): -+ p[ci, perms[ci]] = 1.0 -+ -+ p[:, perms[krank:]] = proj[:, :] -+ inds1, tau1 = idzr_qrpiv(col, krank) -+ # idz_rinqr and idz_rearr -+ r = np.triu(col[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r[:, [ci, inds1[ci]]] = r[:, [inds1[ci], ci]] -+ -+ t = p.T.conj().copy() -+ inds2, tau2 = idzr_qrpiv(t, krank) -+ r2 = np.triu(t[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r2[:, [ci, inds2[ci]]] = r2[:, [inds2[ci], ci]] -+ -+ r3 = r @ r2.T.conj() -+ UU[:krank, :krank], S, V = la.svd(r3, full_matrices=False) -+ -+ # Apply Q of col to U from the left -+ # But do the adjoint dance for LAPACK via U.H @ Q.H -+ np.conjugate(tau1, out=tau1) -+ C = col[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &m, &krank, &C[0, 0], &m, &tau1[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ VV[:krank, :krank] = V[:, :].conj().T -+ -+ # Apply Q of t to V from the left -+ # But do the adjoint dance for LAPACK via V.H @ Q.H -+ np.conjugate(tau2, out=tau2) -+ C = t[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &n, &krank, &C[0, 0], &n, &tau2[0], -+ &VV[0, 0], &krank, &a[0, 0], &info) -+ -+ return UU, S, VV -+ -+ -+def idzp_id(cnp.ndarray[cnp.complex128_t, mode="c", ndim=2] a, cnp.float64_t eps): -+ cdef int n = a.shape[1], krank, tmp_int, p -+ cdef double complex one = 1 -+ krank, _, inds = idzp_qrpiv(a, eps) -+ -+ # Change pivots to permutation -+ perms = cnp.PyArray_Arange(0, n, 1, cnp.NPY_INT64) -+ -+ if krank > 0: -+ for p in range(krank): -+ # Apply pivots -+ tmp_int = perms[p] -+ perms[p] = perms[inds[p]] -+ perms[inds[p]] = tmp_int -+ -+ tmp_int = n - krank -+ # SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB -+ ztrsm('R', 'L', 'N', 'N', -+ &tmp_int, &krank, &one, &a[0, 0], &n, &a[0, krank], &n) -+ -+ return krank, perms, a[:krank, krank:] -+ -+ -+def idzp_qrpiv(cnp.ndarray[cnp.complex128_t, mode="c", ndim=2] a, cnp.float64_t eps): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef cnp.ndarray col_norms = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ cdef int k = 0, kpiv = 0, i = 0, tmp_int = 0, int_n = 0 -+ cdef double complex tmp_sca = 0. -+ cdef cnp.ndarray taus = cnp.PyArray_ZEROS(1, [m], cnp.NPY_COMPLEX128, 0) -+ cdef cnp.ndarray ind = cnp.PyArray_ZEROS(1, [n], cnp.NPY_INT64, 0) -+ cdef double complex[::1] taus_v = taus -+ cdef cnp.float64_t feps = 0.1e-16 # Smaller than np.finfo(np.float64).eps -+ cdef cnp.float64_t ssmax, ssmaxin -+ cdef int nupdate = 0 -+ -+ for i in range(n): -+ col_norms[i] = dznrm2(&m, &a[0, i], &n)**2 -+ -+ kpiv = np.argmax(col_norms) -+ ssmax = col_norms[kpiv] -+ ssmaxin = ssmax -+ -+ for k in range(min(m, n)): -+ -+ # Pivoting -+ ind[k] = kpiv -+ # Swap columns a[:, k] and a[:, kpiv] -+ a[:, [kpiv, k]] = a[:, [k, kpiv]] -+ -+ # Swap col_norms[krank] and col_norms[kpiv] -+ col_norms[[kpiv, k]] = col_norms[[k, kpiv]] -+ -+ if k < m-1: -+ # Compute the householder reflector for column k -+ tmp_sca = a[k, k] -+ # FIX: Convert these to F_INT -+ tmp_int = (m - k) -+ int_n = n -+ zlarfgp(&tmp_int, &tmp_sca, &a[k+1, k], &int_n, &taus_v[k]) -+ -+ # Overwrite with 1. for easy matmul -+ a[k, k] = 1.0 -+ if k < n-1: -+ # Apply the householder reflector to the rest on the right. -+ # Note! Tau returned by zlarfgp is complex valued and thus, -+ # reflector is not Hermitian, hence the conjugates. See the -+ # documentation of zlarfgp. -+ a[k:, k+1:] -= np.outer(taus[k].conj()*a[k:, k], -+ a[k:, k].conj() @ a[k:, k+1:] -+ ) -+ -+ # Put back the beta in place -+ a[k, k] = tmp_sca -+ # Update the norms -+ col_norms[k] = 0 -+ col_norms[k+1:] -= (a[k, k+1:] * a[k, k+1:].conj()).real -+ ssmax = 0.0 -+ kpiv = k+1 -+ -+ if k < n-1: -+ kpiv = np.argmax(col_norms[k+1:]) + (k + 1) -+ ssmax = col_norms[kpiv] -+ -+ if (((ssmax < 1000*feps*ssmaxin) and (nupdate == 0)) or -+ ((ssmax < ((1000*feps)**2)*ssmaxin) and (nupdate == 1))): -+ nupdate += 1 -+ ssmax = 0 -+ kpiv = k+1 -+ if k < n-1: -+ for i in range(k+1, n): -+ tmp_int = m-k-1 -+ col_norms[i] = dznrm2(&tmp_int, &a[k+1, i], &n)**2 -+ kpiv = np.argmax(col_norms[k+1:]) + (k + 1) -+ ssmax = col_norms[kpiv] -+ if (ssmax <= (eps**2)*ssmaxin): -+ break -+ # a is overwritten; return numerical rank and pivots -+ -+ return k+1, taus, ind -+ -+ -+def idzp_rid(A: LinearOperator, cnp.float64_t eps, rng=None): -+ _, ret = idz_findrank(A, eps, rng=rng) -+ return idzp_id(ret, eps=eps) -+ -+ -+def idzp_rsvd(A: LinearOperator, cnp.float64_t eps, rng=None): -+ cdef int n = A.shape[1] -+ cdef int krank, j -+ cdef cnp.ndarray[cnp.int64_t, mode='c', ndim=1] perms -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] col -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] x -+ -+ krank, perms, proj = idzp_rid(A, eps, rng=rng) -+ -+ if krank > 0: -+ # idd_getcols -+ col = cnp.PyArray_EMPTY(2, [n, krank], cnp.NPY_COMPLEX128, 0) -+ x = cnp.PyArray_ZEROS(1, [n], cnp.NPY_COMPLEX128, 0) -+ -+ for j in range(krank): -+ x[perms[j]] = 1. -+ col[:, j] = A.matvec(x) -+ x[perms[j]] = 0. -+ -+ return idz_id2svd(cols=col, perms=perms, proj=proj) -+ -+ # TODO: figure out empty return -+ return None -+ -+ -+def idzp_svd(cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] a, cnp.float64_t eps): -+ cdef int m = a.shape[0], krank, info -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] taus -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] V -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] r -+ cdef cnp.ndarray[cnp.complex128_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.float64_t, ndim=1] S -+ -+ # Get the pivoted QR -+ krank, taus, inds = idzp_qrpiv(a, eps) -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_COMPLEX128, 0) -+ -+ if krank > 0: -+ r = np.triu(a[:krank, :]) -+ -+ for p in range(krank-1, -1, -1): -+ r[:, [p, inds[p]]] = r[:, [inds[p], p]] -+ -+ UU[:krank, :krank], S, V = la.svd(r, full_matrices=False) -+ # Apply Q to U via zunm2r -+ np.conjugate(taus, out=taus) -+ # But do the adjoint dance for LAPACK via U.H @ Q.H; use a for scratch -+ C = a[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &m, &krank, &C[0, 0], &m, &taus[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ return UU, S, V -+ -+ -+def idzr_aid(cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] a: NDArray, int krank, -+ rng=None): -+ cdef int m = a.shape[0], n2, L, nblock, nsteps = 3, mb -+ cdef cnp.float64_t twopi = 2*np.pi, fact -+ cdef double complex twopii = twopi*1.j -+ cdef cnp.ndarray[cnp.npy_int64, mode='c', ndim=1] ind -+ cdef cnp.ndarray[cnp.npy_int64, mode='c', ndim=1] subselect -+ cdef cnp.ndarray[cnp.npy_float64, mode='c', ndim=1] dm1 -+ cdef cnp.ndarray[cnp.npy_float64, mode='c', ndim=1] dm2 -+ cdef cnp.ndarray[cnp.npy_float64, mode='c', ndim=3] albetas -+ cdef cnp.ndarray[cnp.npy_float64, mode='c', ndim=2] rta -+ cdef cnp.ndarray[cnp.npy_float64, mode='c', ndim=2] giv2x2 -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ n2 = 0 -+ L = krank + 8 -+ if (L >= n2) or (L > m): -+ inds, proj = idzr_id(a, krank) -+ return inds, proj -+ -+ n2 = idd_poweroftwo(m) -+ # This part is the initialization that is done via idz_frmi -+ # for a Subsampled Randomized Fourier Transfmrom (SRFT). -+ -+ # Draw (nsteps x m x 4) array from [0, 2)*pi uniformly for -+ # random points on complex unit circle and unitary rotations -+ albetas = np.empty([nsteps, m, 4]) -+ albetas[:, :, 2:] = rng.uniform(low=0.0, high=2.0, size=[nsteps, m, 2]) -+ albetas[:, :, 2:] *= np.pi -+ np.cos(albetas[:, :, 2], out=albetas[:, :, 0]) -+ np.sin(albetas[:, :, 2], out=albetas[:, :, 1]) -+ np.cos(albetas[:, :, 3], out=albetas[:, :, 2]) -+ np.sin(albetas[:, :, 3], out=albetas[:, :, 3]) -+ -+ # idd_random_transf -+ rta = a.copy() -+ -+ # Rotate and shuffle "a" nsteps-many times -+ giv2x2 = np.array([[0., 0. ], [0., 0.]]) -+ for nstep in range(nsteps): -+ # Multiply with a point on the unit circle -+ rta *= albetas[nstep, :, 2:].view(np.complex128) -+ # Rotate -+ for row in range(m-1): -+ alpha, beta = albetas[nstep, row, 0], albetas[nstep, row, 1] -+ giv2x2[0, 0] = alpha -+ giv2x2[0, 1] = beta -+ giv2x2[1, 0] = -beta -+ giv2x2[1, 1] = alpha -+ np.matmul(giv2x2, rta[row:row+2, :], out=rta[row:row+2, :]) -+ -+ rta = rta[rng.permutation(m), :] -+ -+ # idd_subselect pick randomly n2-many rows -+ subselect = rng.choice(m, n2, replace=False) -+ rta = rta[subselect, :] -+ ind = rng.choice(n2, L, replace=False) -+ -+ nblock = idd_ldiv(L, n2) -+ mb = n2 // nblock -+ fact = 1.0 / np.sqrt(n2) -+ -+ # Create (L x mb) DFT matrix -+ # wsave = np.empty([L, mb], dtype=np.complex128) -+ dm1, dm2 = np.divmod(ind, mb, dtype=np.float64) -+ dm1 /= n2 -+ dm1 += dm2 / mb -+ wsave = np.outer(dm1, -twopii*np.arange(mb)) -+ np.exp(wsave, out=wsave) -+ wsave *= fact -+ -+ # Perform partial FFT to each nblock then swap first two axes for transposition -+ # and subsample by ind // mb. This is basically a few options combined into one -+ # First we view each column as (nblock x mb) then take fft of each mb-long chunk. -+ # Then we transpose and multiply with DFT matrix and subselect. -+ # See DOI:10.1016/j.acha.2007.12.002 - Section 3.3 -+ -+ # Original fortran code does this single column at a time. We do a bit of array -+ # manipulation to do it in one go for all columns at once. -+ F = np.swapaxes( -+ fft(rta.reshape(nblock, mb, -1, order='F'), axis=0), 0, 1 -+ )[:, ind // mb, :] -+ # Perform direct calculation with DFT matrix -+ V = np.einsum('ij,jim->im', wsave, F) -+ -+ return idzr_id(V, krank) -+ -+ -+def idzr_asvd(cnp.ndarray[cnp.complex128_t, mode="c", ndim=2] a, int krank, rng=None): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef int info, ci -+ cdef cnp.ndarray[cnp.complex128_t, mode='fortran', ndim=2] C -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau1 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] tau2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.float64_t, mode='c', ndim=1] S -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] V -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] VV -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] perms -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds1 -+ cdef cnp.ndarray[cnp.npy_int64, ndim=1] inds2 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] p -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] col -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_COMPLEX128, 0) -+ VV = cnp.PyArray_ZEROS(2, [n, krank], cnp.NPY_COMPLEX128, 0) -+ p = cnp.PyArray_ZEROS(2, [krank, n], cnp.NPY_COMPLEX128, 0) -+ -+ perms, proj = idzr_aid(a.copy(), krank=krank, rng=rng) -+ col = a[:, perms[:krank]].copy() -+ -+ # idd_reconint -+ for ci in range(krank): -+ p[ci, perms[ci]] = 1.0 -+ -+ p[:, perms[krank:]] = proj[:, :] -+ inds1, tau1 = idzr_qrpiv(col, krank) -+ # idz_rinqr and idz_rearr -+ r = np.triu(col[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r[:, [ci, inds1[ci]]] = r[:, [inds1[ci], ci]] -+ -+ t = p.T.conj().copy() -+ inds2, tau2 = idzr_qrpiv(t, krank) -+ r2 = np.triu(t[:krank, :]) -+ for ci in range(krank-1, -1, -1): -+ r2[:, [ci, inds2[ci]]] = r2[:, [inds2[ci], ci]] -+ -+ r3 = r @ r2.T.conj() -+ UU[:krank, :krank], S, V = la.svd(r3, full_matrices=False) -+ -+ # Apply Q of col to U from the left -+ # But do the adjoint dance for LAPACK via U.H @ Q.H -+ np.conjugate(tau1, out=tau1) -+ C = col[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &m, &krank, &C[0, 0], &m, &tau1[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ VV[:krank, :krank] = V[:, :].conj().T -+ -+ # Apply Q of t to V from the left -+ # But do the adjoint dance for LAPACK via V.H @ Q.H -+ np.conjugate(tau2, out=tau2) -+ C = t[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &n, &krank, &C[0, 0], &n, &tau2[0], -+ &VV[0, 0], &krank, &a[0, 0], &info) -+ -+ return UU, S, VV -+ -+ -+def idzr_id(cnp.ndarray[cnp.complex128_t, ndim=2] a, int krank): -+ cdef int n = a.shape[1], tmp_int, p -+ cdef double complex one = 1.0 -+ cdef cnp.ndarray[cnp.int64_t, ndim=1] inds -+ cdef cnp.ndarray[cnp.int64_t, ndim=1] perms -+ -+ inds, _ = idzr_qrpiv(a, krank) -+ perms = cnp.PyArray_Arange(0, n, 1, cnp.NPY_INT64) -+ -+ if krank > 0: -+ for p in range(krank): -+ # Apply pivots -+ tmp_int = perms[p] -+ perms[p] = perms[inds[p]] -+ perms[inds[p]] = tmp_int -+ tmp_int = n - krank -+ # SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB -+ ztrsm('R', 'L', 'N', 'N', -+ &tmp_int, &krank, &one, &a[0, 0], &n, &a[0, krank], &n) -+ -+ return perms, a[:krank, krank:] -+ -+ -+def idzr_qrpiv(cnp.ndarray[cnp.complex128_t, mode="c", ndim=2] a, int krank): -+ cdef int m = a.shape[0], n = a.shape[1] -+ cdef int loop = 0, loops, kpiv = 0, i = 0, tmp_int = 0 -+ cdef cnp.ndarray col_norms = cnp.PyArray_ZEROS(1, [n], cnp.NPY_FLOAT64, 0) -+ cdef double complex tmp_sca = 0. -+ cdef cnp.ndarray taus = cnp.PyArray_ZEROS(1, [m], cnp.NPY_COMPLEX128, 0) -+ cdef cnp.ndarray ind = cnp.PyArray_ZEROS(1, [n], cnp.NPY_INT64, 0) -+ cdef double complex[::1] taus_v = taus -+ cdef cnp.float64_t feps = 0.1e-16 # Smaller than np.finfo(np.float64).eps -+ cdef cnp.float64_t ssmax, ssmaxin -+ cdef int nupdate = 0 -+ -+ loops = min(krank, min(m, n)) -+ for i in range(n): -+ col_norms[i] = dznrm2(&m, &a[0, i], &n)**2 -+ -+ kpiv = np.argmax(col_norms) -+ ssmax = col_norms[kpiv] -+ ssmaxin = ssmax -+ -+ for loop in range(loops): -+ -+ ind[loop] = kpiv -+ # Swap columns a[:, k] and a[:, kpiv] -+ a[:, [kpiv, loop]] = a[:, [loop, kpiv]] -+ # Swap col_norms[krank] and col_norms[kpiv] -+ col_norms[[kpiv, loop]] = col_norms[[loop, kpiv]] -+ -+ if loop < m-1: -+ tmp_sca = a[loop, loop] -+ # FIX: Convert these to F_INT -+ tmp_int = (m - loop) -+ zlarfgp(&tmp_int, &tmp_sca, &a[loop+1, loop], &n, &taus_v[loop]) -+ -+ # Overwrite with 1. for easy matmul -+ a[loop, loop] = 1 -+ if loop < n-1: -+ # Apply the householder reflector to the rest on the right -+ a[loop:, loop+1:] -= np.outer( -+ np.conj(taus[loop])*a[loop:, loop], -+ a[loop:, loop].conj() @ a[loop:, loop+1:] -+ ) -+ # Put back the beta in place -+ a[loop, loop] = tmp_sca -+ -+ # Update the norms -+ col_norms[loop] = 0 -+ col_norms[loop+1:] -= (a[loop, loop+1:]*a[loop, loop+1:].conj()).real -+ ssmax = 0 -+ kpiv = loop+1 -+ -+ if loop < n-1: -+ kpiv = np.argmax(col_norms[loop+1:]) + (loop + 1) -+ ssmax = col_norms[kpiv] -+ if (((ssmax < 1000*feps*ssmaxin) and (nupdate == 0)) or -+ ((ssmax < ((1000*feps)**2)*ssmaxin) and (nupdate == 1))): -+ nupdate += 1 -+ ssmax = 0 -+ kpiv = loop+1 -+ -+ if loop < n-1: -+ for i in range(loop+1, n): -+ tmp_int = m-loop-1 -+ col_norms[i] = dznrm2(&tmp_int, &a[loop+1, i], &n)**2 -+ kpiv = np.argmax(col_norms[loop+1:]) + (loop + 1) -+ ssmax = col_norms[kpiv] -+ -+ return ind, taus -+ -+ -+def idzr_rid(A: LinearOperator, int krank, rng=None): -+ cdef int m = A.shape[0], n = A.shape[1], k = 0 -+ cdef int L = min(krank+2, min(m, n)) -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] r -+ -+ if not rng: -+ rng = np.random.default_rng() -+ -+ r = cnp.PyArray_EMPTY(2, [L, n], cnp.NPY_COMPLEX128, 0) -+ for k in range(L): -+ r[k, :] = A.rmatvec(rng.uniform(size=(m,2)).view(np.complex128).ravel()) -+ -+ return idzr_id(a=r.conj(), krank=krank) -+ -+ -+def idzr_rsvd(A: LinearOperator, int krank, rng=None): -+ cdef int n = A.shape[1], j -+ cdef cnp.ndarray[cnp.int64_t, mode='c', ndim=1] perms -+ cdef cnp.ndarray[cnp.complex128_t, ndim=2] proj -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] col -+ -+ perms, proj = idzr_rid(A, krank, rng) -+ # idd_getcols -+ col = cnp.PyArray_EMPTY(2, [n, krank], cnp.NPY_COMPLEX128, 0) -+ x = cnp.PyArray_ZEROS(1, [n], cnp.NPY_COMPLEX128, 0) -+ for j in range(krank): -+ x[perms[j]] = 1. -+ col[:, j] = A.matvec(x) -+ x[perms[j]] = 0. -+ -+ return idz_id2svd(cols=col, perms=perms, proj=proj) -+ -+ -+def idzr_svd(cnp.ndarray[cnp.complex128_t, mode="c", ndim=2] a, int krank): -+ cdef int m = a.shape[0], n = a.shape[1], info = 0 -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=1] taus -+ cdef cnp.ndarray[cnp.int64_t, mode='c', ndim=1] inds -+ cdef cnp.ndarray[cnp.complex128_t, mode='c', ndim=2] UU -+ cdef cnp.ndarray[cnp.complex128_t, mode='fortran', ndim=2] C -+ UU = cnp.PyArray_ZEROS(2, [m, krank], cnp.NPY_COMPLEX128, 0) -+ -+ krank = min(krank, min(m, n)) -+ # Get the pivoted QR -+ inds, taus = idzr_qrpiv(a, krank) -+ r = np.triu(a[:krank, :]) -+ # Apply pivots in reverse -+ for p in range(krank-1, -1, -1): -+ r[:, [p, inds[p]]] = r[:, [inds[p], p]] -+ -+ # JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO -+ # zgesvd() -+ UU[:krank, :krank], S, V = la.svd(r, full_matrices=False) -+ -+ # Apply Q to U via zunm2r -+ np.conjugate(taus, out=taus) -+ # But do the adjoint dance for LAPACK via U.H @ Q.H; use a for scratch -+ C = a[:, :krank].conj().copy(order='F') -+ zunm2r('R', 'C', -+ &krank, &m, &krank, &C[0, 0], &m, &taus[0], -+ &UU[0,0], &krank, &a[0, 0], &info) -+ -+ return UU, S, V -diff --git a/scipy/linalg/_interpolative_backend.py b/scipy/linalg/_interpolative_backend.py -deleted file mode 100644 -index 7835314f7..000000000 ---- a/scipy/linalg/_interpolative_backend.py -+++ /dev/null -@@ -1,1681 +0,0 @@ --#****************************************************************************** --# Copyright (C) 2013 Kenneth L. Ho --# --# Redistribution and use in source and binary forms, with or without --# modification, are permitted provided that the following conditions are met: --# --# Redistributions of source code must retain the above copyright notice, this --# list of conditions and the following disclaimer. Redistributions in binary --# form must reproduce the above copyright notice, this list of conditions and --# the following disclaimer in the documentation and/or other materials --# provided with the distribution. --# --# None of the names of the copyright holders may be used to endorse or --# promote products derived from this software without specific prior written --# permission. --# --# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE --# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE --# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR --# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF --# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS --# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN --# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) --# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE --# POSSIBILITY OF SUCH DAMAGE. --#****************************************************************************** -- --""" --Direct wrappers for Fortran `id_dist` backend. --""" -- --import scipy.linalg._interpolative as _id --import numpy as np -- --_RETCODE_ERROR = RuntimeError("nonzero return code") -- -- --def _asfortranarray_copy(A): -- """ -- Same as np.asfortranarray, but ensure a copy -- """ -- A = np.asarray(A) -- if A.flags.f_contiguous: -- A = A.copy(order="F") -- else: -- A = np.asfortranarray(A) -- return A -- -- --#------------------------------------------------------------------------------ --# id_rand.f --#------------------------------------------------------------------------------ -- --def id_srand(n): -- """ -- Generate standard uniform pseudorandom numbers via a very efficient lagged -- Fibonacci method. -- -- :param n: -- Number of pseudorandom numbers to generate. -- :type n: int -- -- :return: -- Pseudorandom numbers. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.id_srand(n) -- -- --def id_srandi(t): -- """ -- Initialize seed values for :func:`id_srand` (any appropriately random -- numbers will do). -- -- :param t: -- Array of 55 seed values. -- :type t: :class:`numpy.ndarray` -- """ -- t = np.asfortranarray(t) -- _id.id_srandi(t) -- -- --def id_srando(): -- """ -- Reset seed values to their original values. -- """ -- _id.id_srando() -- -- --#------------------------------------------------------------------------------ --# idd_frm.f --#------------------------------------------------------------------------------ -- --def idd_frm(n, w, x): -- """ -- Transform real vector via a composition of Rokhlin's random transform, -- random subselection, and an FFT. -- -- In contrast to :func:`idd_sfrm`, this routine works best when the length of -- the transformed vector is the power-of-two integer output by -- :func:`idd_frmi`, or when the length is not specified but instead -- determined a posteriori from the output. The returned transformed vector is -- randomly permuted. -- -- :param n: -- Greatest power-of-two integer satisfying `n <= x.size` as obtained from -- :func:`idd_frmi`; `n` is also the length of the output vector. -- :type n: int -- :param w: -- Initialization array constructed by :func:`idd_frmi`. -- :type w: :class:`numpy.ndarray` -- :param x: -- Vector to be transformed. -- :type x: :class:`numpy.ndarray` -- -- :return: -- Transformed vector. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idd_frm(n, w, x) -- -- --def idd_sfrm(l, n, w, x): -- """ -- Transform real vector via a composition of Rokhlin's random transform, -- random subselection, and an FFT. -- -- In contrast to :func:`idd_frm`, this routine works best when the length of -- the transformed vector is known a priori. -- -- :param l: -- Length of transformed vector, satisfying `l <= n`. -- :type l: int -- :param n: -- Greatest power-of-two integer satisfying `n <= x.size` as obtained from -- :func:`idd_sfrmi`. -- :type n: int -- :param w: -- Initialization array constructed by :func:`idd_sfrmi`. -- :type w: :class:`numpy.ndarray` -- :param x: -- Vector to be transformed. -- :type x: :class:`numpy.ndarray` -- -- :return: -- Transformed vector. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idd_sfrm(l, n, w, x) -- -- --def idd_frmi(m): -- """ -- Initialize data for :func:`idd_frm`. -- -- :param m: -- Length of vector to be transformed. -- :type m: int -- -- :return: -- Greatest power-of-two integer `n` satisfying `n <= m`. -- :rtype: int -- :return: -- Initialization array to be used by :func:`idd_frm`. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idd_frmi(m) -- -- --def idd_sfrmi(l, m): -- """ -- Initialize data for :func:`idd_sfrm`. -- -- :param l: -- Length of output transformed vector. -- :type l: int -- :param m: -- Length of the vector to be transformed. -- :type m: int -- -- :return: -- Greatest power-of-two integer `n` satisfying `n <= m`. -- :rtype: int -- :return: -- Initialization array to be used by :func:`idd_sfrm`. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idd_sfrmi(l, m) -- -- --#------------------------------------------------------------------------------ --# idd_id.f --#------------------------------------------------------------------------------ -- --def iddp_id(eps, A): -- """ -- Compute ID of a real matrix to a specified relative precision. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Rank of ID. -- :rtype: int -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = _asfortranarray_copy(A) -- k, idx, rnorms = _id.iddp_id(eps, A) -- n = A.shape[1] -- proj = A.T.ravel()[:k*(n-k)].reshape((k, n-k), order='F') -- return k, idx, proj -- -- --def iddr_id(A, k): -- """ -- Compute ID of a real matrix to a specified rank. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = _asfortranarray_copy(A) -- idx, rnorms = _id.iddr_id(A, k) -- n = A.shape[1] -- proj = A.T.ravel()[:k*(n-k)].reshape((k, n-k), order='F') -- return idx, proj -- -- --def idd_reconid(B, idx, proj): -- """ -- Reconstruct matrix from real ID. -- -- :param B: -- Skeleton matrix. -- :type B: :class:`numpy.ndarray` -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- :param proj: -- Interpolation coefficients. -- :type proj: :class:`numpy.ndarray` -- -- :return: -- Reconstructed matrix. -- :rtype: :class:`numpy.ndarray` -- """ -- B = np.asfortranarray(B) -- if proj.size > 0: -- return _id.idd_reconid(B, idx, proj) -- else: -- return B[:, np.argsort(idx)] -- -- --def idd_reconint(idx, proj): -- """ -- Reconstruct interpolation matrix from real ID. -- -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- :param proj: -- Interpolation coefficients. -- :type proj: :class:`numpy.ndarray` -- -- :return: -- Interpolation matrix. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idd_reconint(idx, proj) -- -- --def idd_copycols(A, k, idx): -- """ -- Reconstruct skeleton matrix from real ID. -- -- :param A: -- Original matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of ID. -- :type k: int -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- -- :return: -- Skeleton matrix. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- return _id.idd_copycols(A, k, idx) -- -- --#------------------------------------------------------------------------------ --# idd_id2svd.f --#------------------------------------------------------------------------------ -- --def idd_id2svd(B, idx, proj): -- """ -- Convert real ID to SVD. -- -- :param B: -- Skeleton matrix. -- :type B: :class:`numpy.ndarray` -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- :param proj: -- Interpolation coefficients. -- :type proj: :class:`numpy.ndarray` -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- B = np.asfortranarray(B) -- U, V, S, ier = _id.idd_id2svd(B, idx, proj) -- if ier: -- raise _RETCODE_ERROR -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idd_snorm.f --#------------------------------------------------------------------------------ -- --def idd_snorm(m, n, matvect, matvec, its=20): -- """ -- Estimate spectral norm of a real matrix by the randomized power method. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the matrix transpose to a vector, with call signature -- `y = matvect(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvect: function -- :param matvec: -- Function to apply the matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- :param its: -- Number of power method iterations. -- :type its: int -- -- :return: -- Spectral norm estimate. -- :rtype: float -- """ -- snorm, v = _id.idd_snorm(m, n, matvect, matvec, its) -- return snorm -- -- --def idd_diffsnorm(m, n, matvect, matvect2, matvec, matvec2, its=20): -- """ -- Estimate spectral norm of the difference of two real matrices by the -- randomized power method. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the transpose of the first matrix to a vector, with -- call signature `y = matvect(x)`, where `x` and `y` are the input and -- output vectors, respectively. -- :type matvect: function -- :param matvect2: -- Function to apply the transpose of the second matrix to a vector, with -- call signature `y = matvect2(x)`, where `x` and `y` are the input and -- output vectors, respectively. -- :type matvect2: function -- :param matvec: -- Function to apply the first matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- :param matvec2: -- Function to apply the second matrix to a vector, with call signature -- `y = matvec2(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec2: function -- :param its: -- Number of power method iterations. -- :type its: int -- -- :return: -- Spectral norm estimate of matrix difference. -- :rtype: float -- """ -- return _id.idd_diffsnorm(m, n, matvect, matvect2, matvec, matvec2, its) -- -- --#------------------------------------------------------------------------------ --# idd_svd.f --#------------------------------------------------------------------------------ -- --def iddr_svd(A, k): -- """ -- Compute SVD of a real matrix to a specified rank. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of SVD. -- :type k: int -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- U, V, S, ier = _id.iddr_svd(A, k) -- if ier: -- raise _RETCODE_ERROR -- return U, V, S -- -- --def iddp_svd(eps, A): -- """ -- Compute SVD of a real matrix to a specified relative precision. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- k, iU, iV, iS, w, ier = _id.iddp_svd(eps, A) -- if ier: -- raise _RETCODE_ERROR -- U = w[iU-1:iU+m*k-1].reshape((m, k), order='F') -- V = w[iV-1:iV+n*k-1].reshape((n, k), order='F') -- S = w[iS-1:iS+k-1] -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# iddp_aid.f --#------------------------------------------------------------------------------ -- --def iddp_aid(eps, A): -- """ -- Compute ID of a real matrix to a specified relative precision using random -- sampling. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Rank of ID. -- :rtype: int -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- n2, w = idd_frmi(m) -- proj = np.empty(n*(2*n2 + 1) + n2 + 1, order='F') -- k, idx, proj = _id.iddp_aid(eps, A, w, proj) -- proj = proj[:k*(n-k)].reshape((k, n-k), order='F') -- return k, idx, proj -- -- --def idd_estrank(eps, A): -- """ -- Estimate rank of a real matrix to a specified relative precision using -- random sampling. -- -- The output rank is typically about 8 higher than the actual rank. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Rank estimate. -- :rtype: int -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- n2, w = idd_frmi(m) -- ra = np.empty(n*n2 + (n + 1)*(n2 + 1), order='F') -- k, ra = _id.idd_estrank(eps, A, w, ra) -- return k -- -- --#------------------------------------------------------------------------------ --# iddp_asvd.f --#------------------------------------------------------------------------------ -- --def iddp_asvd(eps, A): -- """ -- Compute SVD of a real matrix to a specified relative precision using random -- sampling. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- n2, winit = _id.idd_frmi(m) -- w = np.empty( -- max((min(m, n) + 1)*(3*m + 5*n + 1) + 25*min(m, n)**2, -- (2*n + 1)*(n2 + 1)), -- order='F') -- k, iU, iV, iS, w, ier = _id.iddp_asvd(eps, A, winit, w) -- if ier: -- raise _RETCODE_ERROR -- U = w[iU-1:iU+m*k-1].reshape((m, k), order='F') -- V = w[iV-1:iV+n*k-1].reshape((n, k), order='F') -- S = w[iS-1:iS+k-1] -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# iddp_rid.f --#------------------------------------------------------------------------------ -- --def iddp_rid(eps, m, n, matvect): -- """ -- Compute ID of a real matrix to a specified relative precision using random -- matrix-vector multiplication. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the matrix transpose to a vector, with call signature -- `y = matvect(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvect: function -- -- :return: -- Rank of ID. -- :rtype: int -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- proj = np.empty(m + 1 + 2*n*(min(m, n) + 1), order='F') -- k, idx, proj, ier = _id.iddp_rid(eps, m, n, matvect, proj) -- if ier != 0: -- raise _RETCODE_ERROR -- proj = proj[:k*(n-k)].reshape((k, n-k), order='F') -- return k, idx, proj -- -- --def idd_findrank(eps, m, n, matvect): -- """ -- Estimate rank of a real matrix to a specified relative precision using -- random matrix-vector multiplication. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the matrix transpose to a vector, with call signature -- `y = matvect(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvect: function -- -- :return: -- Rank estimate. -- :rtype: int -- """ -- k, ra, ier = _id.idd_findrank(eps, m, n, matvect) -- if ier: -- raise _RETCODE_ERROR -- return k -- -- --#------------------------------------------------------------------------------ --# iddp_rsvd.f --#------------------------------------------------------------------------------ -- --def iddp_rsvd(eps, m, n, matvect, matvec): -- """ -- Compute SVD of a real matrix to a specified relative precision using random -- matrix-vector multiplication. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the matrix transpose to a vector, with call signature -- `y = matvect(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvect: function -- :param matvec: -- Function to apply the matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- k, iU, iV, iS, w, ier = _id.iddp_rsvd(eps, m, n, matvect, matvec) -- if ier: -- raise _RETCODE_ERROR -- U = w[iU-1:iU+m*k-1].reshape((m, k), order='F') -- V = w[iV-1:iV+n*k-1].reshape((n, k), order='F') -- S = w[iS-1:iS+k-1] -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# iddr_aid.f --#------------------------------------------------------------------------------ -- --def iddr_aid(A, k): -- """ -- Compute ID of a real matrix to a specified rank using random sampling. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- w = iddr_aidi(m, n, k) -- idx, proj = _id.iddr_aid(A, k, w) -- if k == n: -- proj = np.empty((k, n-k), dtype='float64', order='F') -- else: -- proj = proj.reshape((k, n-k), order='F') -- return idx, proj -- -- --def iddr_aidi(m, n, k): -- """ -- Initialize array for :func:`iddr_aid`. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Initialization array to be used by :func:`iddr_aid`. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.iddr_aidi(m, n, k) -- -- --#------------------------------------------------------------------------------ --# iddr_asvd.f --#------------------------------------------------------------------------------ -- --def iddr_asvd(A, k): -- """ -- Compute SVD of a real matrix to a specified rank using random sampling. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of SVD. -- :type k: int -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- w = np.empty((2*k + 28)*m + (6*k + 21)*n + 25*k**2 + 100, order='F') -- w_ = iddr_aidi(m, n, k) -- w[:w_.size] = w_ -- U, V, S, ier = _id.iddr_asvd(A, k, w) -- if ier != 0: -- raise _RETCODE_ERROR -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# iddr_rid.f --#------------------------------------------------------------------------------ -- --def iddr_rid(m, n, matvect, k): -- """ -- Compute ID of a real matrix to a specified rank using random matrix-vector -- multiplication. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the matrix transpose to a vector, with call signature -- `y = matvect(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvect: function -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- idx, proj = _id.iddr_rid(m, n, matvect, k) -- proj = proj[:k*(n-k)].reshape((k, n-k), order='F') -- return idx, proj -- -- --#------------------------------------------------------------------------------ --# iddr_rsvd.f --#------------------------------------------------------------------------------ -- --def iddr_rsvd(m, n, matvect, matvec, k): -- """ -- Compute SVD of a real matrix to a specified rank using random matrix-vector -- multiplication. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matvect: -- Function to apply the matrix transpose to a vector, with call signature -- `y = matvect(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvect: function -- :param matvec: -- Function to apply the matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- :param k: -- Rank of SVD. -- :type k: int -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- U, V, S, ier = _id.iddr_rsvd(m, n, matvect, matvec, k) -- if ier != 0: -- raise _RETCODE_ERROR -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idz_frm.f --#------------------------------------------------------------------------------ -- --def idz_frm(n, w, x): -- """ -- Transform complex vector via a composition of Rokhlin's random transform, -- random subselection, and an FFT. -- -- In contrast to :func:`idz_sfrm`, this routine works best when the length of -- the transformed vector is the power-of-two integer output by -- :func:`idz_frmi`, or when the length is not specified but instead -- determined a posteriori from the output. The returned transformed vector is -- randomly permuted. -- -- :param n: -- Greatest power-of-two integer satisfying `n <= x.size` as obtained from -- :func:`idz_frmi`; `n` is also the length of the output vector. -- :type n: int -- :param w: -- Initialization array constructed by :func:`idz_frmi`. -- :type w: :class:`numpy.ndarray` -- :param x: -- Vector to be transformed. -- :type x: :class:`numpy.ndarray` -- -- :return: -- Transformed vector. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idz_frm(n, w, x) -- -- --def idz_sfrm(l, n, w, x): -- """ -- Transform complex vector via a composition of Rokhlin's random transform, -- random subselection, and an FFT. -- -- In contrast to :func:`idz_frm`, this routine works best when the length of -- the transformed vector is known a priori. -- -- :param l: -- Length of transformed vector, satisfying `l <= n`. -- :type l: int -- :param n: -- Greatest power-of-two integer satisfying `n <= x.size` as obtained from -- :func:`idz_sfrmi`. -- :type n: int -- :param w: -- Initialization array constructed by :func:`idd_sfrmi`. -- :type w: :class:`numpy.ndarray` -- :param x: -- Vector to be transformed. -- :type x: :class:`numpy.ndarray` -- -- :return: -- Transformed vector. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idz_sfrm(l, n, w, x) -- -- --def idz_frmi(m): -- """ -- Initialize data for :func:`idz_frm`. -- -- :param m: -- Length of vector to be transformed. -- :type m: int -- -- :return: -- Greatest power-of-two integer `n` satisfying `n <= m`. -- :rtype: int -- :return: -- Initialization array to be used by :func:`idz_frm`. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idz_frmi(m) -- -- --def idz_sfrmi(l, m): -- """ -- Initialize data for :func:`idz_sfrm`. -- -- :param l: -- Length of output transformed vector. -- :type l: int -- :param m: -- Length of the vector to be transformed. -- :type m: int -- -- :return: -- Greatest power-of-two integer `n` satisfying `n <= m`. -- :rtype: int -- :return: -- Initialization array to be used by :func:`idz_sfrm`. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idz_sfrmi(l, m) -- -- --#------------------------------------------------------------------------------ --# idz_id.f --#------------------------------------------------------------------------------ -- --def idzp_id(eps, A): -- """ -- Compute ID of a complex matrix to a specified relative precision. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Rank of ID. -- :rtype: int -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = _asfortranarray_copy(A) -- k, idx, rnorms = _id.idzp_id(eps, A) -- n = A.shape[1] -- proj = A.T.ravel()[:k*(n-k)].reshape((k, n-k), order='F') -- return k, idx, proj -- -- --def idzr_id(A, k): -- """ -- Compute ID of a complex matrix to a specified rank. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = _asfortranarray_copy(A) -- idx, rnorms = _id.idzr_id(A, k) -- n = A.shape[1] -- proj = A.T.ravel()[:k*(n-k)].reshape((k, n-k), order='F') -- return idx, proj -- -- --def idz_reconid(B, idx, proj): -- """ -- Reconstruct matrix from complex ID. -- -- :param B: -- Skeleton matrix. -- :type B: :class:`numpy.ndarray` -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- :param proj: -- Interpolation coefficients. -- :type proj: :class:`numpy.ndarray` -- -- :return: -- Reconstructed matrix. -- :rtype: :class:`numpy.ndarray` -- """ -- B = np.asfortranarray(B) -- if proj.size > 0: -- return _id.idz_reconid(B, idx, proj) -- else: -- return B[:, np.argsort(idx)] -- -- --def idz_reconint(idx, proj): -- """ -- Reconstruct interpolation matrix from complex ID. -- -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- :param proj: -- Interpolation coefficients. -- :type proj: :class:`numpy.ndarray` -- -- :return: -- Interpolation matrix. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idz_reconint(idx, proj) -- -- --def idz_copycols(A, k, idx): -- """ -- Reconstruct skeleton matrix from complex ID. -- -- :param A: -- Original matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of ID. -- :type k: int -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- -- :return: -- Skeleton matrix. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- return _id.idz_copycols(A, k, idx) -- -- --#------------------------------------------------------------------------------ --# idz_id2svd.f --#------------------------------------------------------------------------------ -- --def idz_id2svd(B, idx, proj): -- """ -- Convert complex ID to SVD. -- -- :param B: -- Skeleton matrix. -- :type B: :class:`numpy.ndarray` -- :param idx: -- Column index array. -- :type idx: :class:`numpy.ndarray` -- :param proj: -- Interpolation coefficients. -- :type proj: :class:`numpy.ndarray` -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- B = np.asfortranarray(B) -- U, V, S, ier = _id.idz_id2svd(B, idx, proj) -- if ier: -- raise _RETCODE_ERROR -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idz_snorm.f --#------------------------------------------------------------------------------ -- --def idz_snorm(m, n, matveca, matvec, its=20): -- """ -- Estimate spectral norm of a complex matrix by the randomized power method. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the matrix adjoint to a vector, with call signature -- `y = matveca(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matveca: function -- :param matvec: -- Function to apply the matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- :param its: -- Number of power method iterations. -- :type its: int -- -- :return: -- Spectral norm estimate. -- :rtype: float -- """ -- snorm, v = _id.idz_snorm(m, n, matveca, matvec, its) -- return snorm -- -- --def idz_diffsnorm(m, n, matveca, matveca2, matvec, matvec2, its=20): -- """ -- Estimate spectral norm of the difference of two complex matrices by the -- randomized power method. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the adjoint of the first matrix to a vector, with -- call signature `y = matveca(x)`, where `x` and `y` are the input and -- output vectors, respectively. -- :type matveca: function -- :param matveca2: -- Function to apply the adjoint of the second matrix to a vector, with -- call signature `y = matveca2(x)`, where `x` and `y` are the input and -- output vectors, respectively. -- :type matveca2: function -- :param matvec: -- Function to apply the first matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- :param matvec2: -- Function to apply the second matrix to a vector, with call signature -- `y = matvec2(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec2: function -- :param its: -- Number of power method iterations. -- :type its: int -- -- :return: -- Spectral norm estimate of matrix difference. -- :rtype: float -- """ -- return _id.idz_diffsnorm(m, n, matveca, matveca2, matvec, matvec2, its) -- -- --#------------------------------------------------------------------------------ --# idz_svd.f --#------------------------------------------------------------------------------ -- --def idzr_svd(A, k): -- """ -- Compute SVD of a complex matrix to a specified rank. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of SVD. -- :type k: int -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- U, V, S, ier = _id.idzr_svd(A, k) -- if ier: -- raise _RETCODE_ERROR -- return U, V, S -- -- --def idzp_svd(eps, A): -- """ -- Compute SVD of a complex matrix to a specified relative precision. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- k, iU, iV, iS, w, ier = _id.idzp_svd(eps, A) -- if ier: -- raise _RETCODE_ERROR -- U = w[iU-1:iU+m*k-1].reshape((m, k), order='F') -- V = w[iV-1:iV+n*k-1].reshape((n, k), order='F') -- S = w[iS-1:iS+k-1] -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idzp_aid.f --#------------------------------------------------------------------------------ -- --def idzp_aid(eps, A): -- """ -- Compute ID of a complex matrix to a specified relative precision using -- random sampling. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Rank of ID. -- :rtype: int -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- n2, w = idz_frmi(m) -- proj = np.empty(n*(2*n2 + 1) + n2 + 1, dtype='complex128', order='F') -- k, idx, proj = _id.idzp_aid(eps, A, w, proj) -- proj = proj[:k*(n-k)].reshape((k, n-k), order='F') -- return k, idx, proj -- -- --def idz_estrank(eps, A): -- """ -- Estimate rank of a complex matrix to a specified relative precision using -- random sampling. -- -- The output rank is typically about 8 higher than the actual rank. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Rank estimate. -- :rtype: int -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- n2, w = idz_frmi(m) -- ra = np.empty(n*n2 + (n + 1)*(n2 + 1), dtype='complex128', order='F') -- k, ra = _id.idz_estrank(eps, A, w, ra) -- return k -- -- --#------------------------------------------------------------------------------ --# idzp_asvd.f --#------------------------------------------------------------------------------ -- --def idzp_asvd(eps, A): -- """ -- Compute SVD of a complex matrix to a specified relative precision using -- random sampling. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- n2, winit = _id.idz_frmi(m) -- w = np.empty( -- max((min(m, n) + 1)*(3*m + 5*n + 11) + 8*min(m, n)**2, -- (2*n + 1)*(n2 + 1)), -- dtype=np.complex128, order='F') -- k, iU, iV, iS, w, ier = _id.idzp_asvd(eps, A, winit, w) -- if ier: -- raise _RETCODE_ERROR -- U = w[iU-1:iU+m*k-1].reshape((m, k), order='F') -- V = w[iV-1:iV+n*k-1].reshape((n, k), order='F') -- S = w[iS-1:iS+k-1] -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idzp_rid.f --#------------------------------------------------------------------------------ -- --def idzp_rid(eps, m, n, matveca): -- """ -- Compute ID of a complex matrix to a specified relative precision using -- random matrix-vector multiplication. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the matrix adjoint to a vector, with call signature -- `y = matveca(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matveca: function -- -- :return: -- Rank of ID. -- :rtype: int -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- proj = np.empty( -- m + 1 + 2*n*(min(m, n) + 1), -- dtype=np.complex128, order='F') -- k, idx, proj, ier = _id.idzp_rid(eps, m, n, matveca, proj) -- if ier: -- raise _RETCODE_ERROR -- proj = proj[:k*(n-k)].reshape((k, n-k), order='F') -- return k, idx, proj -- -- --def idz_findrank(eps, m, n, matveca): -- """ -- Estimate rank of a complex matrix to a specified relative precision using -- random matrix-vector multiplication. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the matrix adjoint to a vector, with call signature -- `y = matveca(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matveca: function -- -- :return: -- Rank estimate. -- :rtype: int -- """ -- k, ra, ier = _id.idz_findrank(eps, m, n, matveca) -- if ier: -- raise _RETCODE_ERROR -- return k -- -- --#------------------------------------------------------------------------------ --# idzp_rsvd.f --#------------------------------------------------------------------------------ -- --def idzp_rsvd(eps, m, n, matveca, matvec): -- """ -- Compute SVD of a complex matrix to a specified relative precision using -- random matrix-vector multiplication. -- -- :param eps: -- Relative precision. -- :type eps: float -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the matrix adjoint to a vector, with call signature -- `y = matveca(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matveca: function -- :param matvec: -- Function to apply the matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- k, iU, iV, iS, w, ier = _id.idzp_rsvd(eps, m, n, matveca, matvec) -- if ier: -- raise _RETCODE_ERROR -- U = w[iU-1:iU+m*k-1].reshape((m, k), order='F') -- V = w[iV-1:iV+n*k-1].reshape((n, k), order='F') -- S = w[iS-1:iS+k-1] -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idzr_aid.f --#------------------------------------------------------------------------------ -- --def idzr_aid(A, k): -- """ -- Compute ID of a complex matrix to a specified rank using random sampling. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- w = idzr_aidi(m, n, k) -- idx, proj = _id.idzr_aid(A, k, w) -- if k == n: -- proj = np.empty((k, n-k), dtype='complex128', order='F') -- else: -- proj = proj.reshape((k, n-k), order='F') -- return idx, proj -- -- --def idzr_aidi(m, n, k): -- """ -- Initialize array for :func:`idzr_aid`. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Initialization array to be used by :func:`idzr_aid`. -- :rtype: :class:`numpy.ndarray` -- """ -- return _id.idzr_aidi(m, n, k) -- -- --#------------------------------------------------------------------------------ --# idzr_asvd.f --#------------------------------------------------------------------------------ -- --def idzr_asvd(A, k): -- """ -- Compute SVD of a complex matrix to a specified rank using random sampling. -- -- :param A: -- Matrix. -- :type A: :class:`numpy.ndarray` -- :param k: -- Rank of SVD. -- :type k: int -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- A = np.asfortranarray(A) -- m, n = A.shape -- w = np.empty( -- (2*k + 22)*m + (6*k + 21)*n + 8*k**2 + 10*k + 90, -- dtype='complex128', order='F') -- w_ = idzr_aidi(m, n, k) -- w[:w_.size] = w_ -- U, V, S, ier = _id.idzr_asvd(A, k, w) -- if ier: -- raise _RETCODE_ERROR -- return U, V, S -- -- --#------------------------------------------------------------------------------ --# idzr_rid.f --#------------------------------------------------------------------------------ -- --def idzr_rid(m, n, matveca, k): -- """ -- Compute ID of a complex matrix to a specified rank using random -- matrix-vector multiplication. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the matrix adjoint to a vector, with call signature -- `y = matveca(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matveca: function -- :param k: -- Rank of ID. -- :type k: int -- -- :return: -- Column index array. -- :rtype: :class:`numpy.ndarray` -- :return: -- Interpolation coefficients. -- :rtype: :class:`numpy.ndarray` -- """ -- idx, proj = _id.idzr_rid(m, n, matveca, k) -- proj = proj[:k*(n-k)].reshape((k, n-k), order='F') -- return idx, proj -- -- --#------------------------------------------------------------------------------ --# idzr_rsvd.f --#------------------------------------------------------------------------------ -- --def idzr_rsvd(m, n, matveca, matvec, k): -- """ -- Compute SVD of a complex matrix to a specified rank using random -- matrix-vector multiplication. -- -- :param m: -- Matrix row dimension. -- :type m: int -- :param n: -- Matrix column dimension. -- :type n: int -- :param matveca: -- Function to apply the matrix adjoint to a vector, with call signature -- `y = matveca(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matveca: function -- :param matvec: -- Function to apply the matrix to a vector, with call signature -- `y = matvec(x)`, where `x` and `y` are the input and output vectors, -- respectively. -- :type matvec: function -- :param k: -- Rank of SVD. -- :type k: int -- -- :return: -- Left singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Right singular vectors. -- :rtype: :class:`numpy.ndarray` -- :return: -- Singular values. -- :rtype: :class:`numpy.ndarray` -- """ -- U, V, S, ier = _id.idzr_rsvd(m, n, matveca, matvec, k) -- if ier: -- raise _RETCODE_ERROR -- return U, V, S -diff --git a/scipy/linalg/interpolative.py b/scipy/linalg/interpolative.py -index b91cdd63a..f946b059f 100644 ---- a/scipy/linalg/interpolative.py -+++ b/scipy/linalg/interpolative.py -@@ -1,4 +1,4 @@ --#****************************************************************************** -+# ****************************************************************************** - # Copyright (C) 2013 Kenneth L. Ho - # - # Redistribution and use in source and binary forms, with or without -@@ -25,19 +25,19 @@ - # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - # POSSIBILITY OF SUCH DAMAGE. --#****************************************************************************** -- --# Python module for interfacing with `id_dist`. -+# ****************************************************************************** - - r""" - ====================================================================== - Interpolative matrix decomposition (:mod:`scipy.linalg.interpolative`) - ====================================================================== - --.. moduleauthor:: Kenneth L. Ho -- - .. versionadded:: 0.13 - -+.. versionchanged:: 1.15.0 -+ The underlying algorithms have been ported to Python from the original Fortran77 -+ code. See references below for more details. -+ - .. currentmodule:: scipy.linalg.interpolative - - An interpolative decomposition (ID) of a matrix :math:`A \in -@@ -94,7 +94,7 @@ Main functionality: - estimate_spectral_norm_diff - estimate_rank - --Support functions: -+Following support functions are deprecated and will be removed in SciPy 1.17.0: - - .. autosummary:: - :toctree: generated/ -@@ -106,16 +106,13 @@ Support functions: - References - ========== - --This module uses the ID software package [1]_ by Martinsson, Rokhlin, --Shkolnisky, and Tygert, which is a Fortran library for computing IDs --using various algorithms, including the rank-revealing QR approach of --[2]_ and the more recent randomized methods described in [3]_, [4]_, --and [5]_. This module exposes its functionality in a way convenient --for Python users. Note that this module does not add any functionality --beyond that of organizing a simpler and more consistent interface. -+This module uses the algorithms found in ID software package [1]_ by Martinsson, -+Rokhlin, Shkolnisky, and Tygert, which is a Fortran library for computing IDs using -+various algorithms, including the rank-revealing QR approach of [2]_ and the more -+recent randomized methods described in [3]_, [4]_, and [5]_. - --We advise the user to consult also the `documentation for the ID package --`_. -+We advise the user to consult also the documentation for the `ID package -+`_. - - .. [1] P.G. Martinsson, V. Rokhlin, Y. Shkolnisky, M. Tygert. "ID: a - software package for low-rank approximation of matrices via interpolative -@@ -356,25 +353,8 @@ depending on the representation. The parameter ``eps`` controls the definition - of the numerical rank. - - Finally, the random number generation required for all randomized routines can --be controlled via :func:`scipy.linalg.interpolative.seed`. To reset the seed --values to their original values, use: -- -->>> sli.seed('default') -- --To specify the seed values, use: -- -->>> s = 42 -->>> sli.seed(s) -- --where ``s`` must be an integer or array of 55 floats. If an integer, the array --of floats is obtained by using ``numpy.random.rand`` with the given integer --seed. -- --To simply generate some random numbers, type: -- -->>> arr = sli.rand(n) -- --where ``n`` is the number of random numbers to generate. -+be controlled via providing NumPy pseudo-random generators with a fixed seed. See -+:class:`numpy.random.Generator` and :func:`numpy.random.default_rng` for more details. - - Remarks - ------- -@@ -385,9 +365,9 @@ backend routine. - - """ - --import scipy.linalg._interpolative_backend as _backend -+import scipy.linalg._decomp_interpolative as _backend - import numpy as np --import sys -+import warnings - - __all__ = [ - 'estimate_rank', -@@ -405,9 +385,18 @@ __all__ = [ - - _DTYPE_ERROR = ValueError("invalid input dtype (input must be float64 or complex128)") - _TYPE_ERROR = TypeError("invalid input type (must be array or LinearOperator)") --_32BIT_ERROR = ValueError("interpolative decomposition on 32-bit systems " -- "with complex128 is buggy") --_IS_32BIT = (sys.maxsize < 2**32) -+ -+ -+def _C_contiguous_copy(A): -+ """ -+ Same as np.ascontiguousarray, but ensure a copy -+ """ -+ A = np.asarray(A) -+ if A.flags.c_contiguous: -+ A = A.copy() -+ else: -+ A = np.ascontiguousarray(A) -+ return A - - - def _is_real(A): -@@ -424,53 +413,29 @@ def _is_real(A): - - def seed(seed=None): - """ -- Seed the internal random number generator used in this ID package. -- -- The generator is a lagged Fibonacci method with 55-element internal state. -- -- Parameters -- ---------- -- seed : int, sequence, 'default', optional -- If 'default', the random seed is reset to a default value. -- -- If `seed` is a sequence containing 55 floating-point numbers -- in range [0,1], these are used to set the internal state of -- the generator. -- -- If the value is an integer, the internal state is obtained -- from `numpy.random.RandomState` (MT19937) with the integer -- used as the initial seed. -- -- If `seed` is omitted (None), ``numpy.random.rand`` is used to -- initialize the generator. -+ This function, historically, used to set the seed of the randomization algorithms -+ used in the `scipy.linalg.interpolative` functions written in Fortran77. - -+ The library has been ported to Python and now the functions use the native NumPy -+ generators and this function has no content and returns None. Thus this function -+ should not be used and will be removed in SciPy version 1.17.0. - """ -- # For details, see :func:`_backend.id_srand`, :func:`_backend.id_srandi`, -- # and :func:`_backend.id_srando`. -- -- if isinstance(seed, str) and seed == 'default': -- _backend.id_srando() -- elif hasattr(seed, '__len__'): -- state = np.asfortranarray(seed, dtype=float) -- if state.shape != (55,): -- raise ValueError("invalid input size") -- elif state.min() < 0 or state.max() > 1: -- raise ValueError("values not in range [0,1]") -- _backend.id_srandi(state) -- elif seed is None: -- _backend.id_srandi(np.random.rand(55)) -- else: -- rnd = np.random.RandomState(seed) -- _backend.id_srandi(rnd.rand(55)) -+ warnings.warn("`scipy.linalg.interpolative.seed` is deprecated and will be " -+ "removed in SciPy 1.17.0.", DeprecationWarning, stacklevel=3) - - - def rand(*shape): - """ -- Generate standard uniform pseudorandom numbers via a very efficient lagged -- Fibonacci method. -+ This function, historically, used to generate uniformly distributed random number -+ for the randomization algorithms used in the `scipy.linalg.interpolative` functions -+ written in Fortran77. - -- This routine is used for all random number generation in this package and -- can affect ID and SVD results. -+ The library has been ported to Python and now the functions use the native NumPy -+ generators. Thus this function should not be used and will be removed in the -+ SciPy version 1.17.0. -+ -+ If pseudo-random numbers are needed, NumPy pseudo-random generators should be used -+ instead. - - Parameters - ---------- -@@ -478,11 +443,13 @@ def rand(*shape): - Shape of output array - - """ -- # For details, see :func:`_backend.id_srand`, and :func:`_backend.id_srando`. -- return _backend.id_srand(np.prod(shape)).reshape(shape) -+ warnings.warn("`scipy.linalg.interpolative.rand` is deprecated and will be " -+ "removed in SciPy 1.17.0.", DeprecationWarning, stacklevel=3) -+ rng = np.random.default_rng() -+ return rng.uniform(low=0., high=1.0, size=shape) - - --def interp_decomp(A, eps_or_k, rand=True): -+def interp_decomp(A, eps_or_k, rand=True, rng=None): - """ - Compute ID of a matrix. - -@@ -546,6 +513,9 @@ def interp_decomp(A, eps_or_k, rand=True): - Whether to use random sampling if `A` is of type :class:`numpy.ndarray` - (randomized algorithms are always used if `A` is of type - :class:`scipy.sparse.linalg.LinearOperator`). -+ rng : :class:`numpy.random.Generator` -+ NumPy generator for the randomization steps in the algorithm. If ``rand`` is -+ ``False``, the argument is ignored. - - Returns - ------- -@@ -562,57 +532,49 @@ def interp_decomp(A, eps_or_k, rand=True): - real = _is_real(A) - - if isinstance(A, np.ndarray): -+ A = _C_contiguous_copy(A) - if eps_or_k < 1: - eps = eps_or_k - if rand: - if real: -- k, idx, proj = _backend.iddp_aid(eps, A) -+ k, idx, proj = _backend.iddp_aid(A, eps, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- k, idx, proj = _backend.idzp_aid(eps, A) -+ k, idx, proj = _backend.idzp_aid(A, eps, rng=rng) - else: - if real: -- k, idx, proj = _backend.iddp_id(eps, A) -+ k, idx, proj = _backend.iddp_id(A, eps) - else: -- k, idx, proj = _backend.idzp_id(eps, A) -- return k, idx - 1, proj -+ k, idx, proj = _backend.idzp_id(A, eps) -+ return k, idx, proj - else: - k = int(eps_or_k) - if rand: - if real: -- idx, proj = _backend.iddr_aid(A, k) -+ idx, proj = _backend.iddr_aid(A, k, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- idx, proj = _backend.idzr_aid(A, k) -+ idx, proj = _backend.idzr_aid(A, k, rng=rng) - else: - if real: - idx, proj = _backend.iddr_id(A, k) - else: - idx, proj = _backend.idzr_id(A, k) -- return idx - 1, proj -+ return idx, proj - elif isinstance(A, LinearOperator): -- m, n = A.shape -- matveca = A.rmatvec -+ - if eps_or_k < 1: - eps = eps_or_k - if real: -- k, idx, proj = _backend.iddp_rid(eps, m, n, matveca) -+ k, idx, proj = _backend.iddp_rid(A, eps, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- k, idx, proj = _backend.idzp_rid(eps, m, n, matveca) -- return k, idx - 1, proj -+ k, idx, proj = _backend.idzp_rid(A, eps, rng=rng) -+ return k, idx, proj - else: - k = int(eps_or_k) - if real: -- idx, proj = _backend.iddr_rid(m, n, matveca, k) -+ idx, proj = _backend.iddr_rid(A, k, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- idx, proj = _backend.idzr_rid(m, n, matveca, k) -- return idx - 1, proj -+ idx, proj = _backend.idzr_rid(A, k, rng=rng) -+ return idx, proj - else: - raise _TYPE_ERROR - -@@ -648,9 +610,9 @@ def reconstruct_matrix_from_id(B, idx, proj): - Reconstructed matrix. - """ - if _is_real(B): -- return _backend.idd_reconid(B, idx + 1, proj) -+ return _backend.idd_reconid(B, idx, proj) - else: -- return _backend.idz_reconid(B, idx + 1, proj) -+ return _backend.idz_reconid(B, idx, proj) - - - def reconstruct_interp_matrix(idx, proj): -@@ -662,10 +624,8 @@ def reconstruct_interp_matrix(idx, proj): - - P = numpy.hstack([numpy.eye(proj.shape[0]), proj])[:,numpy.argsort(idx)] - -- The original matrix can then be reconstructed from its skeleton matrix `B` -- via:: -- -- numpy.dot(B, P) -+ The original matrix can then be reconstructed from its skeleton matrix ``B`` -+ via ``A = B @ P`` - - See also :func:`reconstruct_matrix_from_id` and - :func:`reconstruct_skel_matrix`. -@@ -677,7 +637,7 @@ def reconstruct_interp_matrix(idx, proj): - Parameters - ---------- - idx : :class:`numpy.ndarray` -- Column index array. -+ 1D column index array. - proj : :class:`numpy.ndarray` - Interpolation coefficients. - -@@ -686,10 +646,17 @@ def reconstruct_interp_matrix(idx, proj): - :class:`numpy.ndarray` - Interpolation matrix. - """ -+ n, krank = len(idx), proj.shape[0] - if _is_real(proj): -- return _backend.idd_reconint(idx + 1, proj) -+ p = np.zeros([krank, n], dtype=np.float64) - else: -- return _backend.idz_reconint(idx + 1, proj) -+ p = np.zeros([krank, n], dtype=np.complex128) -+ -+ for ci in range(krank): -+ p[ci, idx[ci]] = 1.0 -+ p[:, idx[krank:]] = proj[:, :] -+ -+ return p - - - def reconstruct_skel_matrix(A, k, idx): -@@ -726,10 +693,7 @@ def reconstruct_skel_matrix(A, k, idx): - :class:`numpy.ndarray` - Skeleton matrix. - """ -- if _is_real(A): -- return _backend.idd_copycols(A, k, idx + 1) -- else: -- return _backend.idz_copycols(A, k, idx + 1) -+ return A[:, idx[:k]] - - - def id_to_svd(B, idx, proj): -@@ -753,7 +717,7 @@ def id_to_svd(B, idx, proj): - B : :class:`numpy.ndarray` - Skeleton matrix. - idx : :class:`numpy.ndarray` -- Column index array. -+ 1D column index array. - proj : :class:`numpy.ndarray` - Interpolation coefficients. - -@@ -766,14 +730,16 @@ def id_to_svd(B, idx, proj): - V : :class:`numpy.ndarray` - Right singular vectors. - """ -+ B = _C_contiguous_copy(B) - if _is_real(B): -- U, V, S = _backend.idd_id2svd(B, idx + 1, proj) -+ U, S, V = _backend.idd_id2svd(B, idx, proj) - else: -- U, V, S = _backend.idz_id2svd(B, idx + 1, proj) -+ U, S, V = _backend.idz_id2svd(B, idx, proj) -+ - return U, S, V - - --def estimate_spectral_norm(A, its=20): -+def estimate_spectral_norm(A, its=20, rng=None): - """ - Estimate spectral norm of a matrix by the randomized power method. - -@@ -788,6 +754,8 @@ def estimate_spectral_norm(A, its=20): - `matvec` and `rmatvec` methods (to apply the matrix and its adjoint). - its : int, optional - Number of power method iterations. -+ rng : :class:`numpy.random.Generator` -+ NumPy generator for the randomization steps in the algorithm. - - Returns - ------- -@@ -796,18 +764,14 @@ def estimate_spectral_norm(A, its=20): - """ - from scipy.sparse.linalg import aslinearoperator - A = aslinearoperator(A) -- m, n = A.shape -- def matvec(x): -- return A.matvec(x) -- def matveca(x): -- return A.rmatvec(x) -+ - if _is_real(A): -- return _backend.idd_snorm(m, n, matveca, matvec, its=its) -+ return _backend.idd_snorm(A, its=its, rng=rng) - else: -- return _backend.idz_snorm(m, n, matveca, matvec, its=its) -+ return _backend.idz_snorm(A, its=its, rng=rng) - - --def estimate_spectral_norm_diff(A, B, its=20): -+def estimate_spectral_norm_diff(A, B, its=20, rng=None): - """ - Estimate spectral norm of the difference of two matrices by the randomized - power method. -@@ -826,6 +790,8 @@ def estimate_spectral_norm_diff(A, B, its=20): - the `matvec` and `rmatvec` methods (to apply the matrix and its adjoint). - its : int, optional - Number of power method iterations. -+ rng : :class:`numpy.random.Generator` -+ NumPy generator for the randomization steps in the algorithm. - - Returns - ------- -@@ -835,30 +801,20 @@ def estimate_spectral_norm_diff(A, B, its=20): - from scipy.sparse.linalg import aslinearoperator - A = aslinearoperator(A) - B = aslinearoperator(B) -- m, n = A.shape -- def matvec1(x): -- return A.matvec(x) -- def matveca1(x): -- return A.rmatvec(x) -- def matvec2(x): -- return B.matvec(x) -- def matveca2(x): -- return B.rmatvec(x) -+ - if _is_real(A): -- return _backend.idd_diffsnorm( -- m, n, matveca1, matveca2, matvec1, matvec2, its=its) -+ return _backend.idd_diffsnorm(A, B, its=its, rng=rng) - else: -- return _backend.idz_diffsnorm( -- m, n, matveca1, matveca2, matvec1, matvec2, its=its) -+ return _backend.idz_diffsnorm(A, B, its=its, rng=rng) - - --def svd(A, eps_or_k, rand=True): -+def svd(A, eps_or_k, rand=True, rng=None): - """ - Compute SVD of a matrix via an ID. - - An SVD of a matrix `A` is a factorization:: - -- A = numpy.dot(U, numpy.dot(numpy.diag(S), V.conj().T)) -+ A = U @ np.diag(S) @ V.conj().T - - where `U` and `V` have orthonormal columns and `S` is nonnegative. - -@@ -889,35 +845,39 @@ def svd(A, eps_or_k, rand=True): - Whether to use random sampling if `A` is of type :class:`numpy.ndarray` - (randomized algorithms are always used if `A` is of type - :class:`scipy.sparse.linalg.LinearOperator`). -+ rng : :class:`numpy.random.Generator` -+ NumPy generator for the randomization steps in the algorithm. If ``rand`` is -+ ``False``, the argument is ignored. - - Returns - ------- - U : :class:`numpy.ndarray` -- Left singular vectors. -+ 2D array of left singular vectors. - S : :class:`numpy.ndarray` -- Singular values. -+ 1D array of singular values. - V : :class:`numpy.ndarray` -- Right singular vectors. -+ 2D array right singular vectors. - """ - from scipy.sparse.linalg import LinearOperator - - real = _is_real(A) - - if isinstance(A, np.ndarray): -+ A = _C_contiguous_copy(A) - if eps_or_k < 1: - eps = eps_or_k - if rand: - if real: -- U, V, S = _backend.iddp_asvd(eps, A) -+ U, S, V = _backend.iddp_asvd(A, eps, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- U, V, S = _backend.idzp_asvd(eps, A) -+ U, S, V = _backend.idzp_asvd(A, eps, rng=rng) - else: - if real: -- U, V, S = _backend.iddp_svd(eps, A) -+ U, S, V = _backend.iddp_svd(A, eps) -+ V = V.T.conj() - else: -- U, V, S = _backend.idzp_svd(eps, A) -+ U, S, V = _backend.idzp_svd(A, eps) -+ V = V.T.conj() - else: - k = int(eps_or_k) - if k > min(A.shape): -@@ -925,44 +885,35 @@ def svd(A, eps_or_k, rand=True): - f" {min(A.shape)} ") - if rand: - if real: -- U, V, S = _backend.iddr_asvd(A, k) -+ U, S, V = _backend.iddr_asvd(A, k, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- U, V, S = _backend.idzr_asvd(A, k) -+ U, S, V = _backend.idzr_asvd(A, k, rng=rng) - else: - if real: -- U, V, S = _backend.iddr_svd(A, k) -+ U, S, V = _backend.iddr_svd(A, k) -+ V = V.T.conj() - else: -- U, V, S = _backend.idzr_svd(A, k) -+ U, S, V = _backend.idzr_svd(A, k) -+ V = V.T.conj() - elif isinstance(A, LinearOperator): -- m, n = A.shape -- def matvec(x): -- return A.matvec(x) -- def matveca(x): -- return A.rmatvec(x) - if eps_or_k < 1: - eps = eps_or_k - if real: -- U, V, S = _backend.iddp_rsvd(eps, m, n, matveca, matvec) -+ U, S, V = _backend.iddp_rsvd(A, eps, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- U, V, S = _backend.idzp_rsvd(eps, m, n, matveca, matvec) -+ U, S, V = _backend.idzp_rsvd(A, eps, rng=rng) - else: - k = int(eps_or_k) - if real: -- U, V, S = _backend.iddr_rsvd(m, n, matveca, matvec, k) -+ U, S, V = _backend.iddr_rsvd(A, k, rng=rng) - else: -- if _IS_32BIT: -- raise _32BIT_ERROR -- U, V, S = _backend.idzr_rsvd(m, n, matveca, matvec, k) -+ U, S, V = _backend.idzr_rsvd(A, k, rng=rng) - else: - raise _TYPE_ERROR - return U, S, V - - --def estimate_rank(A, eps): -+def estimate_rank(A, eps, rng=None): - """ - Estimate matrix rank to a specified relative precision using randomized - methods. -@@ -985,6 +936,8 @@ def estimate_rank(A, eps): - with the `rmatvec` method (to apply the matrix adjoint). - eps : float - Relative error for numerical rank definition. -+ rng : :class:`numpy.random.Generator` -+ NumPy generator for the randomization steps in the algorithm. - - Returns - ------- -@@ -996,20 +949,19 @@ def estimate_rank(A, eps): - real = _is_real(A) - - if isinstance(A, np.ndarray): -+ A = _C_contiguous_copy(A) - if real: -- rank = _backend.idd_estrank(eps, A) -+ rank, _ = _backend.idd_estrank(A, eps, rng=rng) - else: -- rank = _backend.idz_estrank(eps, A) -+ rank, _ = _backend.idz_estrank(A, eps, rng=rng) - if rank == 0: - # special return value for nearly full rank - rank = min(A.shape) - return rank - elif isinstance(A, LinearOperator): -- m, n = A.shape -- matveca = A.rmatvec - if real: -- return _backend.idd_findrank(eps, m, n, matveca) -+ return _backend.idd_findrank(A, eps, rng=rng)[0] - else: -- return _backend.idz_findrank(eps, m, n, matveca) -+ return _backend.idz_findrank(A, eps, rng=rng)[0] - else: - raise _TYPE_ERROR -diff --git a/scipy/linalg/meson.build b/scipy/linalg/meson.build -index cc208092e..777edd008 100644 ---- a/scipy/linalg/meson.build -+++ b/scipy/linalg/meson.build -@@ -111,57 +111,15 @@ py3.extension_module('_flapack', - - # TODO: cblas/clapack are built *only* for ATLAS. Why? Is it still needed? - --# id_dist contains a copy of FFTPACK, which has type mismatch warnings --# that are hard to fix. This code is terrible and noisy during the build, --# silence it completely. --_suppress_all_warnings = ff.get_supported_arguments('-w') -- --py3.extension_module('_interpolative', -- [ -- 'src/id_dist/src/dfft.f', -- 'src/id_dist/src/id_rand.f', -- 'src/id_dist/src/id_rtrans.f', -- 'src/id_dist/src/idd_frm.f', -- 'src/id_dist/src/idd_house.f', -- 'src/id_dist/src/idd_id.f', -- 'src/id_dist/src/idd_id2svd.f', -- 'src/id_dist/src/idd_qrpiv.f', -- 'src/id_dist/src/idd_sfft.f', -- 'src/id_dist/src/idd_snorm.f', -- 'src/id_dist/src/idd_svd.f', -- 'src/id_dist/src/iddp_aid.f', -- 'src/id_dist/src/iddp_asvd.f', -- 'src/id_dist/src/iddp_rid.f', -- 'src/id_dist/src/iddp_rsvd.f', -- 'src/id_dist/src/iddr_aid.f', -- 'src/id_dist/src/iddr_asvd.f', -- 'src/id_dist/src/iddr_rid.f', -- 'src/id_dist/src/iddr_rsvd.f', -- 'src/id_dist/src/idz_frm.f', -- 'src/id_dist/src/idz_house.f', -- 'src/id_dist/src/idz_id.f', -- 'src/id_dist/src/idz_id2svd.f', -- 'src/id_dist/src/idz_qrpiv.f', -- 'src/id_dist/src/idz_sfft.f', -- 'src/id_dist/src/idz_snorm.f', -- 'src/id_dist/src/idz_svd.f', -- 'src/id_dist/src/idzp_aid.f', -- 'src/id_dist/src/idzp_asvd.f', -- 'src/id_dist/src/idzp_rid.f', -- 'src/id_dist/src/idzp_rsvd.f', -- 'src/id_dist/src/idzr_aid.f', -- 'src/id_dist/src/idzr_asvd.f', -- 'src/id_dist/src/idzr_rid.f', -- 'src/id_dist/src/idzr_rsvd.f', -- 'src/id_dist/src/prini.f', -- f2py_gen.process('interpolative.pyf'), -- ], -- fortran_args: [fortran_ignore_warnings, _suppress_all_warnings], -+# _decomp_interpolative -+py3.extension_module('_decomp_interpolative', -+ linalg_init_cython_gen.process('_decomp_interpolative.pyx'), -+ c_args: cython_c_args, -+ dependencies: np_dep, -+ c_args: numpy_nodepr_api, - link_args: version_link_args, -- dependencies: [lapack_dep, fortranobject_dep], - override_options: ['b_lto=false'], - install: true, -- link_language: 'fortran', - subdir: 'scipy/linalg' - ) - -@@ -278,7 +236,6 @@ python_sources = [ - '_decomp_schur.py', - '_decomp_svd.py', - '_expm_frechet.py', -- '_interpolative_backend.py', - '_matfuncs.py', - '_matfuncs_expm.pyi', - '_matfuncs_inv_ssq.py', -diff --git a/scipy/linalg/src/id_dist/README.txt b/scipy/linalg/src/id_dist/README.txt -deleted file mode 100644 -index 000bb1e5f..000000000 ---- a/scipy/linalg/src/id_dist/README.txt -+++ /dev/null -@@ -1,6 +0,0 @@ --Please see the documentation in subdirectory doc of this id_dist directory. -- --At the minimum, please read Subsection 2.1 and Section 3 in the documentation, --and beware that the _N.B._'s in the source code comments highlight important --information about the routines -- _N.B._ stands for _nota_bene_ (Latin for --"note well"). -diff --git a/scipy/linalg/src/id_dist/doc/doc.bib b/scipy/linalg/src/id_dist/doc/doc.bib -deleted file mode 100644 -index 1ab5cb220..000000000 ---- a/scipy/linalg/src/id_dist/doc/doc.bib -+++ /dev/null -@@ -1,19 +0,0 @@ --@book{golub-van_loan, -- author = {Gene Golub and Charles {Van L}oan}, -- title = {Matrix Computations}, -- edition = {Third}, -- publisher = {Johns Hopkins University Press}, -- year = {1996}, -- address = {Baltimore, Maryland} --} -- --@article{halko-martinsson-tropp, -- author = {Nathan Halko and {P.-G.} Martinsson and Joel A. Tropp}, -- title = {Finding structure with randomness: probabilistic algorithms -- for constructing approximate matrix decompositions}, -- journal = {SIAM Review}, -- volume = {53}, -- number = {2}, -- pages = {217--288}, -- year = {2011} --} -diff --git a/scipy/linalg/src/id_dist/doc/doc.tex b/scipy/linalg/src/id_dist/doc/doc.tex -deleted file mode 100644 -index 8bcece8c4..000000000 ---- a/scipy/linalg/src/id_dist/doc/doc.tex -+++ /dev/null -@@ -1,977 +0,0 @@ --\documentclass[letterpaper,12pt]{article} --\usepackage[margin=1in]{geometry} --\usepackage{verbatim} --\usepackage{amsmath} --\usepackage{supertabular} --\usepackage{array} -- --\def\T{{\hbox{\scriptsize{\rm T}}}} --\def\epsilon{\varepsilon} --\def\bigoh{\mathcal{O}} --\def\phi{\varphi} --\def\st{{\hbox{\scriptsize{\rm st}}}} --\def\th{{\hbox{\scriptsize{\rm th}}}} --\def\x{\mathbf{x}} -- -- --\title{ID: A software package for low-rank approximation -- of matrices via interpolative decompositions, Version 0.4} --\author{Per-Gunnar Martinsson, Vladimir Rokhlin,\\ -- Yoel Shkolnisky, and Mark Tygert} -- -- --\begin{document} -- --\maketitle -- --\newpage -- --{\parindent=0pt -- --The present document and all of the software --in the accompanying distribution (which is contained in the directory --{\tt id\_dist} and its subdirectories, or in the file --{\tt id\_dist.tar.gz})\, is -- --\bigskip -- --Copyright \copyright\ 2014 by P.-G. Martinsson, V. Rokhlin, --Y. Shkolnisky, and M. Tygert. -- --\bigskip -- --All rights reserved. -- --\bigskip -- --Redistribution and use in source and binary forms, with or without --modification, are permitted provided that the following conditions are --met: -- --\begin{enumerate} --\item Redistributions of source code must retain the above copyright --notice, this list of conditions, and the following disclaimer. --\item Redistributions in binary form must reproduce the above copyright --notice, this list of conditions, and the following disclaimer in the --documentation and/or other materials provided with the distribution. --\item None of the names of the copyright holders may be used to endorse --or promote products derived from this software without specific prior --written permission. --\end{enumerate} -- --\bigskip -- --THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY --EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR --PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS BE --LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR --CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF --SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR --BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, --WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR --OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF --ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- --} -- --\newpage -- --\tableofcontents -- --\newpage -- -- -- --\hrule -- --\medskip -- --\centerline{\Large \bf IMPORTANT} -- --\medskip -- --\hrule -- --\medskip -- --\noindent At the minimum, please read Subsection~\ref{warning} --and Section~\ref{naming} below, and beware that the {\it N.B.}'s --in the source code comments highlight key information about the routines; --{\it N.B.} stands for {\it nota bene} (Latin for ``note well''). -- --\medskip -- --\hrule -- --\bigskip -- -- -- --\section{Introduction} -- --This software distribution provides Fortran routines --for computing low-rank approximations to matrices, --in the forms of interpolative decompositions (IDs) --and singular value decompositions (SVDs). --The routines use algorithms based on the ID. --The ID is also commonly known as --the approximation obtained via skeletonization, --the approximation obtained via subsampling, --and the approximation obtained via subset selection. --The ID provides many advantages in many applications, --and we suspect that it will become increasingly popular --once tools for its computation become more widely available. --This software distribution includes some such tools, --as well as tools for computing low-rank approximations --in the form of SVDs. --Section~\ref{defs} below defines IDs and SVDs, --and provides references to detailed discussions of the algorithms --used in this software package. -- --Please beware that normalized power iterations are better suited than --the software in this distribution --for computing principal component analyses --in the typical case when the square of the signal-to-noise ratio --is not orders of magnitude greater than both dimensions --of the data matrix; see~\cite{halko-martinsson-tropp}. -- --The algorithms used in this distribution have been optimized --for accuracy, efficiency, and reliability; --as a somewhat counterintuitive consequence, many must be randomized. --All randomized codes in this software package succeed --with overwhelmingly high probability (see, for example, --\cite{halko-martinsson-tropp}). --The truly paranoid are welcome to use the routines {\tt idd\_diffsnorm} --and {\tt idz\_diffsnorm} to evaluate rapidly the quality --of the approximations produced by the randomized algorithms --(as done, for example, in the files --{\tt idd\_a\_test.f}, {\tt idd\_r\_test.f}, {\tt idz\_a\_test.f}, --and {\tt idz\_r\_test.f} in the {\tt test} subdirectory --of the main directory {\tt id\_dist}). --In most circumstances, evaluating the quality of an approximation --via routines {\tt idd\_diffsnorm} or {\tt idz\_diffsnorm} is much faster --than forming the approximation to be evaluated. Still, we are unaware --of any instance in which a properly-compiled routine failed to produce --an accurate approximation. --To facilitate successful compilation, we encourage the user --to read the instructions in the next section, --and to read Section~\ref{naming}, too. -- -- -- --\section{Compilation instructions} -- -- --Followed in numerical order, the subsections of this section --provide step-by-step instructions for compiling the software --under a Unix-compatible operating system. -- -- --\subsection{Beware that default command-line flags may not be -- sufficient for compiling the source codes!} --\label{warning} -- --The Fortran source codes in this distribution pass {\tt real*8} --variables as integer variables, integers as {\tt real*8}'s, --{\tt real*8}'s as {\tt complex*16}'s, and so on. --This is common practice in numerical codes, and is not an error; --be sure to provide the relevant command-line flags to the compiler --(for example, run {\tt fort77} and {\tt f2c} with the flag {\tt -!P}). --When following the compilation instructions --in Subsection~\ref{makefile_edit} below, --be sure to set {\tt FFLAGS} appropriately. -- -- --\subsection{Install LAPACK} -- --The SVD routines in this distribution depend on LAPACK. --Before compiling the present distribution, --create the LAPACK and BLAS archive (library) {\tt .a} files; --information about installing LAPACK is available --at {\tt http://www.netlib.org/lapack/} (and several other web sites). -- -- --\subsection{Decompress and untar the file {\tt id\_dist.tar.gz}} -- --At the command line, decompress and untar the file --{\tt id\_dist.tar.gz} by issuing a command such as --{\tt tar -xvvzf id\_dist.tar.gz}. --This will create a directory named {\tt id\_dist}. -- -- --\subsection{Edit the Makefile} --\label{makefile_edit} -- --The directory {\tt id\_dist} contains a file named {\tt Makefile}. --In {\tt Makefile}, set the following: --% --\begin{itemize} --\item {\tt FC} is the Fortran compiler. --\item {\tt FFLAGS} is the set of command-line flags -- (specifying optimization settings, for example) -- for the Fortran compiler specified by {\tt FC}; -- please heed the warning in Subsection~\ref{warning} above! --\item {\tt BLAS\_LIB} is the file-system path to the BLAS archive -- (library) {\tt .a} file. --\item {\tt LAPACK\_LIB} is the file-system path to the LAPACK archive -- (library) {\tt .a} file. --\item {\tt ARCH} is the archiver utility (usually {\tt ar}). --\item {\tt ARCHFLAGS} is the set of command-line flags -- for the archiver specified by {\tt ARCH} needed -- to create an archive (usually {\tt cr}). --\item {\tt RANLIB} is to be set to {\tt ranlib} -- when {\tt ranlib} is available, and is to be set to {\tt echo} -- when {\tt ranlib} is not available. --\end{itemize} -- -- --\subsection{Make and test the libraries} -- --At the command line in a shell that adheres --to the Bourne shell conventions for redirection, issue the command --``{\tt make clean; make}'' to both create the archive (library) --{\tt id\_lib.a} and test it. --(In most modern Unix distributions, {\tt sh} is the Bourne shell, --or else is fully compatible with the Bourne shell; --the Korn shell {\tt ksh} and the Bourne-again shell {\tt bash} --also use the Bourne shell conventions for redirection.) --{\tt make} places the file {\tt id\_lib.a} --in the directory {\tt id\_dist}; the archive (library) file --{\tt id\_lib.a} contains machine code for all user-callable routines --in this distribution. -- -- -- --\section{Naming conventions} --\label{naming} -- --The names of routines and files in this distribution --start with prefixes, followed by an underscore (``\_''). --The prefixes are two to four characters in length, --and have the following meanings: --% --\begin{itemize} --\item The first two letters are always ``{\tt id}'', -- the name of this distribution. --\item The third letter (when present) is either ``{\tt d}'' -- or ``{\tt z}''; -- ``{\tt d}'' stands for double precision ({\tt real*8}), -- and ``{\tt z}'' stands for double complex ({\tt complex*16}). --\item The fourth letter (when present) is either ``{\tt r}'' -- or ``{\tt p}''; -- ``{\tt r}'' stands for specified rank, -- and ``{\tt p}'' stands for specified precision. -- The specified rank routines require the user to provide -- the rank of the approximation to be constructed, -- while the specified precision routines adjust the rank adaptively -- to attain the desired precision. --\end{itemize} -- --For example, {\tt iddr\_aid} is a {\tt real*8} routine which computes --an approximation of specified rank. --{\tt idz\_snorm} is a {\tt complex*16} routine. --{\tt id\_randperm} is yet another routine in this distribution. -- -- -- --\section{Example programs} -- --For examples of how to use the user-callable routines --in this distribution, see the source codes in subdirectory {\tt test} --of the main directory {\tt id\_dist}. -- -- -- --\section{Directory structure} -- --The main {\tt id\_dist} directory contains a Makefile, --the auxiliary text files {\tt README.txt} and {\tt size.txt}, --and the following subdirectories, described in the subsections below: --% --\begin{enumerate} --\item {\tt bin} --\item {\tt development} --\item {\tt doc} --\item {\tt src} --\item {\tt test} --\item {\tt tmp} --\end{enumerate} --% --If a ``{\tt make all}'' command has completed successfully, --then the main {\tt id\_dist} directory will also contain --an archive (library) file {\tt id\_lib.a} containing machine code --for all of the user-callable routines. -- -- --\subsection{Subdirectory {\tt bin}} -- --Once all of the libraries have been made via the Makefile --in the main {\tt id\_dist} directory, --the subdirectory {\tt bin} will contain object files (machine code), --each compiled from the corresponding file of source code --in the subdirectory {\tt src} of {\tt id\_dist}. -- -- --\subsection{Subdirectory {\tt development}} -- --Each Fortran file in the subdirectory {\tt development} --(except for {\tt dfft.f} and {\tt prini.f}) --specifies its dependencies at the top, then provides a main program --for testing and debugging, and finally provides source code --for a library of user-callable subroutines. --The Fortran file {\tt dfft.f} is a copy of P. N. Swarztrauber's FFTPACK library --for computing fast Fourier transforms. --The Fortran file {\tt prini.f} is a copy of V. Rokhlin's library --of formatted printing routines. --Both {\tt dfft.f} (version 4) and {\tt prini.f} are in the public domain. --The shell script {\tt RUNME.sh} runs shell scripts {\tt make\_src.sh} --and {\tt make\_test.sh}, which fill the subdirectories {\tt src} --and {\tt test} of the main directory {\tt id\_dist} --with source codes for user-callable routines --and with the main program testing codes. -- -- --\subsection{Subdirectory {\tt doc}} -- --Subdirectory {\tt doc} contains this documentation, --supplementing comments in the source codes. -- -- --\subsection{Subdirectory {\tt src}} -- --The files in the subdirectory {\tt src} provide source code --for software libraries. Each file in the subdirectory {\tt src} --(except for {\tt dfft.f} and {\tt prini.f}) is --the bottom part of the corresponding file --in the subdirectory {\tt development} of {\tt id\_dist}. --The file {\tt dfft.f} is just a copy --of P. N. Swarztrauber's FFTPACK library --for computing fast Fourier transforms. --The file {\tt prini.f} is a copy of V. Rokhlin's library --of formatted printing routines. --Both {\tt dfft.f} (version 4) and {\tt prini.f} are in the public domain. -- -- --\subsection{Subdirectory {\tt test}} -- --The files in subdirectory {\tt test} provide source code --for testing and debugging. Each file in subdirectory {\tt test} is --the top part of the corresponding file --in subdirectory {\tt development} of {\tt id\_dist}, --and provides a main program and a list of its dependencies. --These codes provide examples of how to call the user-callable routines. -- -- -- --\section{Catalog of the routines} -- --The main routines for decomposing {\tt real*8} matrices are: --% --\begin{enumerate} --% --\item IDs of arbitrary (generally dense) matrices: --{\tt iddp\_id}, {\tt iddr\_id}, {\tt iddp\_aid}, {\tt iddr\_aid} --% --\item IDs of matrices that may be rapidly applied to arbitrary vectors --(as may the matrices' transposes): --{\tt iddp\_rid}, {\tt iddr\_rid} --% --\item SVDs of arbitrary (generally dense) matrices: --{\tt iddp\_svd}, {\tt iddr\_svd}, {\tt iddp\_asvd},\\{\tt iddr\_asvd} --% --\item SVDs of matrices that may be rapidly applied to arbitrary vectors --(as may the matrices' transposes): --{\tt iddp\_rsvd}, {\tt iddr\_rsvd} --% --\end{enumerate} -- --Similarly, the main routines for decomposing {\tt complex*16} matrices --are: --% --\begin{enumerate} --% --\item IDs of arbitrary (generally dense) matrices: --{\tt idzp\_id}, {\tt idzr\_id}, {\tt idzp\_aid}, {\tt idzr\_aid} --% --\item IDs of matrices that may be rapidly applied to arbitrary vectors --(as may the matrices' adjoints): --{\tt idzp\_rid}, {\tt idzr\_rid} --% --\item SVDs of arbitrary (generally dense) matrices: --{\tt idzp\_svd}, {\tt idzr\_svd}, {\tt idzp\_asvd},\\{\tt idzr\_asvd} --% --\item SVDs of matrices that may be rapidly applied to arbitrary vectors --(as may the matrices' adjoints): --{\tt idzp\_rsvd}, {\tt idzr\_rsvd} --% --\end{enumerate} -- --This distribution also includes routines for constructing pivoted $QR$ --decompositions (in {\tt idd\_qrpiv.f} and {\tt idz\_qrpiv.f}), for --estimating the spectral norms of matrices that may be applied rapidly --to arbitrary vectors as may their adjoints (in {\tt idd\_snorm.f} --and {\tt idz\_snorm.f}), for converting IDs to SVDs (in --{\tt idd\_id2svd.f} and {\tt idz\_id2svd.f}), and for computing rapidly --arbitrary subsets of the entries of the discrete Fourier transforms --of vectors (in {\tt idd\_sfft.f} and {\tt idz\_sfft.f}). -- -- --\subsection{List of the routines} -- --The following is an alphabetical list of the routines --in this distribution, together with brief descriptions --of their functionality and the names of the files containing --the routines' source code: -- --\begin{center} --% --\tablehead{\bf Routine & \bf Description & \bf Source file \\} --\tabletail{\hline} --% --\begin{supertabular}{>{\raggedright}p{1.2in} p{.53\textwidth} l} --% --\hline --{\tt id\_frand} & generates pseudorandom numbers drawn uniformly from --the interval $[0,1]$; this routine is more efficient than routine --{\tt id\_srand}, but cannot generate fewer than 55 pseudorandom numbers --per call & {\tt id\_rand.f} \\\hline --% --{\tt id\_frandi} & initializes the seed values for routine --{\tt id\_frand} to specified values & {\tt id\_rand.f} \\\hline --% --{\tt id\_frando} & initializes the seed values for routine --{\tt id\_frand} to their original, default values & {\tt id\_rand.f} --\\\hline --% --{\tt id\_randperm} & generates a uniformly random permutation & --{\tt id\_rand.f} \\\hline --% --{\tt id\_srand} & generates pseudorandom numbers drawn uniformly from --the interval $[0,1]$; this routine is less efficient than routine --{\tt id\_frand}, but can generate fewer than 55 pseudorandom numbers --per call & {\tt id\_rand.f} \\\hline --% --{\tt id\_srandi} & initializes the seed values for routine --{\tt id\_srand} to specified values & {\tt id\_rand.f} \\\hline --% --{\tt id\_srando} & initializes the seed values for routine --{\tt id\_srand} to their original, default values & {\tt id\_rand.f} --\\\hline --% --{\tt idd\_copycols} & collects together selected columns of a matrix & --{\tt idd\_id.f} \\\hline --% --{\tt idd\_diffsnorm} & estimates the spectral norm of the difference --between two matrices specified by routines for applying the matrices --and their transposes to arbitrary vectors; this routine uses the power --method with a random starting vector & {\tt idd\_snorm.f} \\\hline --% --{\tt idd\_enorm} & calculates the Euclidean norm of a vector & --{\tt idd\_snorm.f} \\\hline --% --{\tt idd\_estrank} & estimates the numerical rank of an arbitrary --(generally dense) matrix to a specified precision; this routine is --randomized, and must be initialized with routine {\tt idd\_frmi} & --{\tt iddp\_aid.f} \\\hline --% --{\tt idd\_frm} & transforms a vector into a vector which is --sufficiently scrambled to be subsampled, via a composition of Rokhlin's --random transform, random subselection, and a fast Fourier transform & --{\tt idd\_frm.f} \\\hline --% --{\tt idd\_frmi} & initializes routine {\tt idd\_frm} & {\tt idd\_frm.f} --\\\hline --% --{\tt idd\_getcols} & collects together selected columns of a matrix --specified by a routine for applying the matrix to arbitrary vectors & --{\tt idd\_id.f} \\\hline --% --{\tt idd\_house} & calculates the vector and scalar needed to apply the --Householder transformation reflecting a given vector into its first --entry & {\tt idd\_house.f} \\\hline --% --{\tt idd\_houseapp} & applies a Householder matrix to a vector & --{\tt idd\_house.f} \\\hline --% --{\tt idd\_id2svd} & converts an approximation to a matrix in the form --of an ID into an approximation in the form of an SVD & --{\tt idd\_id2svd.f} \\\hline --% --{\tt idd\_ldiv} & finds the greatest integer less than or equal to a --specified integer, that is divisible by another (larger) specified --integer & {\tt idd\_sfft.f} \\\hline --% --{\tt idd\_pairsamps} & calculates the indices of the pairs of integers --that the individual integers in a specified set belong to & --{\tt idd\_frm.f} \\\hline --% --{\tt idd\_permmult} & multiplies together a bunch of permutations & --{\tt idd\_qrpiv.f} \\\hline --% --{\tt idd\_qinqr} & reconstructs the $Q$ matrix in a $QR$ decomposition --from the output of routines {\tt iddp\_qrpiv} or {\tt iddr\_qrpiv} & --{\tt idd\_qrpiv.f} \\\hline --% --{\tt idd\_qrmatmat} & applies to multiple vectors collected together as --a matrix the $Q$ matrix (or its transpose) in the $QR$ decomposition of --a matrix, as described by the output of routines {\tt iddp\_qrpiv} or --{\tt iddr\_qrpiv}; to apply $Q$ (or its transpose) to a single vector --without having to provide a work array, use routine {\tt idd\_qrmatvec} --instead & {\tt idd\_qrpiv.f} \\\hline --% --{\tt idd\_qrmatvec} & applies to a single vector the $Q$ matrix (or its --transpose) in the $QR$ decomposition of a matrix, as described by the --output of routines {\tt iddp\_qrpiv} or {\tt iddr\_qrpiv}; to apply $Q$ --(or its transpose) to several vectors efficiently, use routine --{\tt idd\_qrmatmat} instead & {\tt idd\_qrpiv.f} \\\hline --% --{\tt idd\_random\_} {\tt transf} & applies rapidly a --random orthogonal matrix to a user-supplied vector & {\tt id\_rtrans.f} --\\\hline --% --{\tt idd\_random\_ transf\_init} & \raggedright initializes routines --{\tt idd\_random\_transf} and {\tt idd\_random\_transf\_inverse} & --{\tt id\_rtrans.f} \\\hline --% --{\tt idd\_random\_} {\tt transf\_inverse} & applies --rapidly the inverse of the operator applied by routine --{\tt idd\_random\_transf} & {\tt id\_rtrans.f} \\\hline --% --{\tt idd\_reconid} & reconstructs a matrix from its ID & --{\tt idd\_id.f} \\\hline --% --{\tt idd\_reconint} & constructs $P$ in the ID $A = B \, P$, where the --columns of $B$ are a subset of the columns of $A$, and $P$ is the --projection coefficient matrix, given {\tt list}, {\tt krank}, and --{\tt proj} output by routines {\tt iddr\_id}, {\tt iddp\_id}, --{\tt iddr\_aid}, {\tt iddp\_aid}, {\tt iddr\_rid}, or {\tt iddp\_rid} & --{\tt idd\_id.f} \\\hline --% --{\tt idd\_sfft} & rapidly computes a subset of the entries of the --discrete Fourier transform of a vector, composed with permutation --matrices both on input and on output & {\tt idd\_sfft.f} \\\hline --% --{\tt idd\_sffti} & initializes routine {\tt idd\_sfft} & --{\tt idd\_sfft.f} \\\hline --% --{\tt idd\_sfrm} & transforms a vector into a scrambled vector of --specified length, via a composition of Rokhlin's random transform, --random subselection, and a fast Fourier transform & {\tt idd\_frm.f} --\\\hline --% --{\tt idd\_sfrmi} & initializes routine {\tt idd\_sfrm} & --{\tt idd\_frm.f} \\\hline --% --{\tt idd\_snorm} & estimates the spectral norm of a matrix specified by --routines for applying the matrix and its transpose to arbitrary --vectors; this routine uses the power method with a random starting --vector & {\tt idd\_snorm.f} \\\hline --% --{\tt iddp\_aid} & computes the ID of an arbitrary (generally dense) --matrix, to a specified precision; this routine is randomized, and must --be initialized with routine {\tt idd\_frmi} & {\tt iddp\_aid.f} --\\\hline --% --{\tt iddp\_asvd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified precision; this routine is randomized, and must --be initialized with routine {\tt idd\_frmi} & {\tt iddp\_asvd.f} --\\\hline --% --{\tt iddp\_id} & computes the ID of an arbitrary (generally dense) --matrix, to a specified precision; this routine is often less efficient --than routine {\tt iddp\_aid} & {\tt idd\_id.f} \\\hline --% --{\tt iddp\_qrpiv} & computes the pivoted $QR$ decomposition of an --arbitrary (generally dense) matrix via Householder transformations, --stopping at a specified precision of the decomposition & --{\tt idd\_qrpiv.f} \\\hline --% --{\tt iddp\_rid} & computes the ID, to a specified precision, of a --matrix specified by a routine for applying its transpose to arbitrary --vectors; this routine is randomized & {\tt iddp\_rid.f} \\\hline --% --{\tt iddp\_rsvd} & computes the SVD, to a specified precision, of a --matrix specified by routines for applying the matrix and its transpose --to arbitrary vectors; this routine is randomized & {\tt iddp\_rsvd.f} --\\\hline --% --{\tt iddp\_svd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified precision; this routine is often less efficient --than routine {\tt iddp\_asvd} & {\tt idd\_svd.f} \\\hline --% --{\tt iddr\_aid} & computes the ID of an arbitrary (generally dense) --matrix, to a specified rank; this routine is randomized, and must be --initialized by routine {\tt iddr\_aidi} & {\tt iddr\_aid.f} \\\hline --% --{\tt iddr\_aidi} & initializes routine {\tt iddr\_aid} & --{\tt iddr\_aid.f} \\\hline --% --{\tt iddr\_asvd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified rank; this routine is randomized, and must be --initialized with routine {\tt idd\_aidi} & {\tt iddr\_asvd.f} --\\\hline --% --{\tt iddr\_id} & computes the ID of an arbitrary (generally dense) --matrix, to a specified rank; this routine is often less efficient than --routine {\tt iddr\_aid} & {\tt idd\_id.f} \\\hline --% --{\tt iddr\_qrpiv} & computes the pivoted $QR$ decomposition of an --arbitrary (generally dense) matrix via Householder transformations, --stopping at a specified rank of the decomposition & {\tt idd\_qrpiv.f} --\\\hline --% --{\tt iddr\_rid} & computes the ID, to a specified rank, of a matrix --specified by a routine for applying its transpose to arbitrary vectors; --this routine is randomized & {\tt iddr\_rid.f} \\\hline --% --{\tt iddr\_rsvd} & computes the SVD, to a specified rank, of a matrix --specified by routines for applying the matrix and its transpose to --arbitrary vectors; this routine is randomized & {\tt iddr\_rsvd.f} --\\\hline --% --{\tt iddr\_svd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified rank; this routine is often less efficient than --routine {\tt iddr\_asvd} & {\tt idd\_svd.f} \\\hline --% --{\tt idz\_copycols} & collects together selected columns of a matrix & --{\tt idz\_id.f} \\\hline --% --{\tt idz\_diffsnorm} & estimates the spectral norm of the difference --between two matrices specified by routines for applying the matrices --and their adjoints to arbitrary vectors; this routine uses the power --method with a random starting vector & {\tt idz\_snorm.f} \\\hline --% --{\tt idz\_enorm} & calculates the Euclidean norm of a vector & --{\tt idz\_snorm.f} \\\hline --% --{\tt idz\_estrank} & estimates the numerical rank of an arbitrary --(generally dense) matrix to a specified precision; this routine is --randomized, and must be initialized with routine {\tt idz\_frmi} & --{\tt idzp\_aid.f} \\\hline --% --{\tt idz\_frm} & transforms a vector into a vector which is --sufficiently scrambled to be subsampled, via a composition of Rokhlin's --random transform, random subselection, and a fast Fourier transform & --{\tt idz\_frm.f} \\\hline --% --{\tt idz\_frmi} & initializes routine {\tt idz\_frm} & {\tt idz\_frm.f} --\\\hline --% --{\tt idz\_getcols} & collects together selected columns of a matrix --specified by a routine for applying the matrix to arbitrary vectors & --{\tt idz\_id.f} \\\hline --% --{\tt idz\_house} & calculates the vector and scalar needed to apply the --Householder transformation reflecting a given vector into its first --entry & {\tt idz\_house.f} \\\hline --% --{\tt idz\_houseapp} & applies a Householder matrix to a vector & --{\tt idz\_house.f} \\\hline --% --{\tt idz\_id2svd} & converts an approximation to a matrix in the form --of an ID into an approximation in the form of an SVD & --{\tt idz\_id2svd.f} \\\hline --% --{\tt idz\_ldiv} & finds the greatest integer less than or equal to a --specified integer, that is divisible by another (larger) specified --integer & {\tt idz\_sfft.f} \\\hline --% --{\tt idz\_permmult} & multiplies together a bunch of permutations & --{\tt idz\_qrpiv.f} \\\hline --% --{\tt idz\_qinqr} & reconstructs the $Q$ matrix in a $QR$ decomposition --from the output of routines {\tt idzp\_qrpiv} or {\tt idzr\_qrpiv} & --{\tt idz\_qrpiv.f} \\\hline --% --{\tt idz\_qrmatmat} & applies to multiple vectors collected together as --a matrix the $Q$ matrix (or its adjoint) in the $QR$ decomposition of --a matrix, as described by the output of routines {\tt idzp\_qrpiv} or --{\tt idzr\_qrpiv}; to apply $Q$ (or its adjoint) to a single vector --without having to provide a work array, use routine {\tt idz\_qrmatvec} --instead & {\tt idz\_qrpiv.f} \\\hline --% --{\tt idz\_qrmatvec} & applies to a single vector the $Q$ matrix (or its --adjoint) in the $QR$ decomposition of a matrix, as described by the --output of routines {\tt idzp\_qrpiv} or {\tt idzr\_qrpiv}; to apply $Q$ --(or its adjoint) to several vectors efficiently, use routine --{\tt idz\_qrmatmat} instead & {\tt idz\_qrpiv.f} \\\hline --% --{\tt idz\_random\_ transf} & applies rapidly a random unitary matrix to --a user-supplied vector & {\tt id\_rtrans.f} \\\hline --% --{\tt idz\_random\_ transf\_init} & \raggedright initializes routines --{\tt idz\_random\_transf} and {\tt idz\_random\_transf\_inverse} & --{\tt id\_rtrans.f} \\\hline --% --{\tt idz\_random\_ transf\_inverse} & applies rapidly the inverse of --the operator applied by routine {\tt idz\_random\_transf} & --{\tt id\_rtrans.f} \\\hline --% --{\tt idz\_reconid} & reconstructs a matrix from its ID & --{\tt idz\_id.f} \\\hline --% --{\tt idz\_reconint} & constructs $P$ in the ID $A = B \, P$, where the --columns of $B$ are a subset of the columns of $A$, and $P$ is the --projection coefficient matrix, given {\tt list}, {\tt krank}, and --{\tt proj} output by routines {\tt idzr\_id}, {\tt idzp\_id}, --{\tt idzr\_aid}, {\tt idzp\_aid}, {\tt idzr\_rid}, or {\tt idzp\_rid} & --{\tt idz\_id.f} \\\hline --% --{\tt idz\_sfft} & rapidly computes a subset of the entries of the --discrete Fourier transform of a vector, composed with permutation --matrices both on input and on output & {\tt idz\_sfft.f} \\\hline --% --{\tt idz\_sffti} & initializes routine {\tt idz\_sfft} & --{\tt idz\_sfft.f} \\\hline --% --{\tt idz\_sfrm} & transforms a vector into a scrambled vector of --specified length, via a composition of Rokhlin's random transform, --random subselection, and a fast Fourier transform & {\tt idz\_frm.f} --\\\hline --% --{\tt idz\_sfrmi} & initializes routine {\tt idz\_sfrm} & --{\tt idz\_frm.f} \\\hline --% --{\tt idz\_snorm} & estimates the spectral norm of a matrix specified by --routines for applying the matrix and its adjoint to arbitrary --vectors; this routine uses the power method with a random starting --vector & {\tt idz\_snorm.f} \\\hline --% --{\tt idzp\_aid} & computes the ID of an arbitrary (generally dense) --matrix, to a specified precision; this routine is randomized, and must --be initialized with routine {\tt idz\_frmi} & {\tt idzp\_aid.f} --\\\hline --% --{\tt idzp\_asvd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified precision; this routine is randomized, and must --be initialized with routine {\tt idz\_frmi} & {\tt idzp\_asvd.f} --\\\hline --% --{\tt idzp\_id} & computes the ID of an arbitrary (generally dense) --matrix, to a specified precision; this routine is often less efficient --than routine {\tt idzp\_aid} & {\tt idz\_id.f} \\\hline --% --{\tt idzp\_qrpiv} & computes the pivoted $QR$ decomposition of an --arbitrary (generally dense) matrix via Householder transformations, --stopping at a specified precision of the decomposition & --{\tt idz\_qrpiv.f} \\\hline --% --{\tt idzp\_rid} & computes the ID, to a specified precision, of a --matrix specified by a routine for applying its adjoint to arbitrary --vectors; this routine is randomized & {\tt idzp\_rid.f} \\\hline --% --{\tt idzp\_rsvd} & computes the SVD, to a specified precision, of a --matrix specified by routines for applying the matrix and its adjoint --to arbitrary vectors; this routine is randomized & {\tt idzp\_rsvd.f} --\\\hline --% --{\tt idzp\_svd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified precision; this routine is often less efficient --than routine {\tt idzp\_asvd} & {\tt idz\_svd.f} \\\hline --% --{\tt idzr\_aid} & computes the ID of an arbitrary (generally dense) --matrix, to a specified rank; this routine is randomized, and must be --initialized by routine {\tt idzr\_aidi} & {\tt idzr\_aid.f} \\\hline --% --{\tt idzr\_aidi} & initializes routine {\tt idzr\_aid} & --{\tt idzr\_aid.f} \\\hline --% --{\tt idzr\_asvd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified rank; this routine is randomized, and must be --initialized with routine {\tt idz\_aidi} & {\tt idzr\_asvd.f} --\\\hline --% --{\tt idzr\_id} & computes the ID of an arbitrary (generally dense) --matrix, to a specified rank; this routine is often less efficient than --routine {\tt idzr\_aid} & {\tt idz\_id.f} \\\hline --% --{\tt idzr\_qrpiv} & computes the pivoted $QR$ decomposition of an --arbitrary (generally dense) matrix via Householder transformations, --stopping at a specified rank of the decomposition & {\tt idz\_qrpiv.f} --\\\hline --% --{\tt idzr\_rid} & computes the ID, to a specified rank, of a matrix --specified by a routine for applying its adjoint to arbitrary vectors; --this routine is randomized & {\tt idzr\_rid.f} \\\hline --% --{\tt idzr\_rsvd} & computes the SVD, to a specified rank, of a matrix --specified by routines for applying the matrix and its adjoint to --arbitrary vectors; this routine is randomized & {\tt idzr\_rsvd.f} --\\\hline --% --{\tt idzr\_svd} & computes the SVD of an arbitrary (generally dense) --matrix, to a specified rank; this routine is often less efficient than --routine {\tt idzr\_asvd} & {\tt idz\_svd.f} \\ --% --\end{supertabular} --\end{center} -- -- -- --\section{Documentation in the source codes} -- --Each routine in the source codes includes documentation --in the comments immediately following the declaration --of the subroutine's calling sequence. --This documentation describes the purpose of the routine, --the input and output variables, and the required work arrays (if any). --This documentation also cites relevant references. --Please pay attention to the {\it N.B.}'s; --{\it N.B.} stands for {\it nota bene} (Latin for ``note well'') --and highlights important information about the routines. -- -- -- --\section{Notation and decompositions} --\label{defs} -- --This section sets notational conventions employed --in this documentation and the associated software, --and defines both the singular value decomposition (SVD) --and the interpolative decomposition (ID). --For information concerning other mathematical objects --used in the code (such as Householder transformations, --pivoted $QR$ decompositions, and discrete and fast Fourier transforms ----- DFTs and FFTs), see, for example,~\cite{golub-van_loan}. --For detailed descriptions and proofs of the mathematical facts --discussed in the present section, see, for example, --\cite{golub-van_loan} and the references --in~\cite{halko-martinsson-tropp}. -- --Throughout this document and the accompanying software distribution, --$\| \x \|$ always denotes the Euclidean norm of the vector $\x$, --and $\| A \|$ always denotes the spectral norm of the matrix $A$. --Subsection~\ref{Euclidean} below defines the Euclidean norm; --Subsection~\ref{spectral} below defines the spectral norm. --We use $A^*$ to denote the adjoint of the matrix $A$. -- -- --\subsection{Euclidean norm} --\label{Euclidean} -- --For any positive integer $n$, and vector $\x$ of length $n$, --the Euclidean ($l^2$) norm $\| \x \|$ is --% --\begin{equation} --\| \x \| = \sqrt{ \sum_{k=1}^n |x_k|^2 }, --\end{equation} --% --where $x_1$,~$x_2$, \dots, $x_{n-1}$,~$x_n$ are the entries of $\x$. -- -- --\subsection{Spectral norm} --\label{spectral} -- --For any positive integers $m$ and $n$, and $m \times n$ matrix $A$, --the spectral ($l^2$ operator) norm $\| A \|$ is --% --\begin{equation} --\| A_{m \times n} \| --= \max \frac{\| A_{m \times n} \, \x_{n \times 1} \|} -- {\| \x_{n \times 1} \|}, --\end{equation} --% --where the $\max$ is taken over all $n \times 1$ column vectors $\x$ --such that $\| \x \| \ne 0$. -- -- --\subsection{Singular value decomposition (SVD)} -- --For any positive real number $\epsilon$, --positive integers $k$, $m$, and $n$ with $k \le m$ and $k \le n$, --and any $m \times n$ matrix $A$, --a rank-$k$ approximation to $A$ in the form of an SVD --(to precision $\epsilon$) consists of an $m \times k$ matrix $U$ --whose columns are orthonormal, an $n \times k$ matrix $V$ --whose columns are orthonormal, and a diagonal $k \times k$ matrix --$\Sigma$ with diagonal entries --$\Sigma_{1,1} \ge \Sigma_{2,2} \ge \dots \ge \Sigma_{n-1,n-1} -- \ge \Sigma_{n,n} \ge 0$, --such that --% --\begin{equation} --\| A_{m \times n} - U_{m \times k} \, \Sigma_{k \times k} -- \, (V^*)_{k \times n} \| \le \epsilon. --\end{equation} --% --The product $U \, \Sigma \, V^*$ is known as an SVD. --The columns of $U$ are known as left singular vectors; --the columns of $V$ are known as right singular vectors. --The diagonal entries of $\Sigma$ are known as singular values. -- --When $k = m$ or $k = n$, and $A = U \, \Sigma \, V^*$, --then $U \, \Sigma \, V^*$ is known as the SVD --of $A$; the columns of $U$ are the left singular vectors of $A$, --the columns of $V$ are the right singular vectors of $A$, --and the diagonal entries of $\Sigma$ are the singular values of $A$. --For any positive integer $k$ with $k < m$ and $k < n$, --there exists a rank-$k$ approximation to $A$ in the form of an SVD, --to precision $\sigma_{k+1}$, where $\sigma_{k+1}$ is the $(k+1)^\st$ --greatest singular value of $A$. -- -- --\subsection{Interpolative decomposition (ID)} -- --For any positive real number $\epsilon$, --positive integers $k$, $m$, and $n$ with $k \le m$ and $k \le n$, --and any $m \times n$ matrix $A$, --a rank-$k$ approximation to $A$ in the form of an ID --(to precision $\epsilon$) consists of a $k \times n$ matrix $P$, --and an $m \times k$ matrix $B$ whose columns constitute a subset --of the columns of $A$, such that --% --\begin{enumerate} --\item $\| A_{m \times n} - B_{m \times k} \, P_{k \times n} \| -- \le \epsilon$, --\item some subset of the columns of $P$ makes up the $k \times k$ -- identity matrix, and --\item every entry of $P$ has an absolute value less than or equal -- to a reasonably small positive real number, say 2. --\end{enumerate} --% --The product $B \, P$ is known as an ID. --The matrix $P$ is known as the projection or interpolation matrix --of the ID. Property~1 above approximates each column of $A$ --via a linear combination of the columns of $B$ --(which are themselves columns of $A$), with the coefficients --in the linear combination given by the entries of $P$. -- --The interpolative decomposition is ``interpolative'' --due to Property~2 above. The ID is numerically stable --due to Property~3 above. --It follows from Property~2 that the least ($k^\th$ greatest) singular value --of $P$ is at least 1. Combining Properties~2 and~3 yields that --% --\begin{equation} --\| P_{k \times n} \| \le \sqrt{4k(n-k)+1}. --\end{equation} -- --When $k = m$ or $k = n$, and $A = B \, P$, --then $B \, P$ is known as the ID of $A$. --For any positive integer $k$ with $k < m$ and $k < n$, --there exists a rank-$k$ approximation to $A$ in the form of an ID, --to precision $\sqrt{k(n-k)+1} \; \sigma_{k+1}$, --where $\sigma_{k+1}$ is the $(k+1)^\st$ greatest singular value of $A$ --(in fact, there exists an ID in which every entry --of the projection matrix $P$ has an absolute value less than or equal --to 1). -- -- -- --\section{Bug reports, feedback, and support} -- --Please let us know about errors in the software or in the documentation --via e-mail to {\tt tygert@aya.yale.edu}. --We would also appreciate hearing about particular applications of the codes, --especially in the form of journal articles --e-mailed to {\tt tygert@aya.yale.edu}. --Mathematical and technical support may also be available via e-mail. Enjoy! -- -- -- --\bibliographystyle{siam} --\bibliography{doc} -- -- --\end{document} -diff --git a/scipy/linalg/src/id_dist/doc/supertabular.sty b/scipy/linalg/src/id_dist/doc/supertabular.sty -deleted file mode 100644 -index ac2638c23..000000000 ---- a/scipy/linalg/src/id_dist/doc/supertabular.sty -+++ /dev/null -@@ -1,483 +0,0 @@ --%% --%% This is file `supertabular.sty', --%% generated with the docstrip utility. --%% --%% The original source files were: --%% --%% supertabular.dtx (with options: `package') --%% Copyright (C) 1989-2004 Johannes Braams. All rights reserved. --%% --%% This file was generated from file(s) of the supertabular package. --%% ----------------------------------------------------------------- --%% --%% It may be distributed and/or modified under the --%% conditions of the LaTeX Project Public License, either version 1.3 --%% of this license or (at your option) any later version. --%% The latest version of this license is in --%% http://www.latex-project.org/lppl.txt --%% and version 1.3 or later is part of all distributions of LaTeX --%% version 2003/12/01 or later. --%% --%% This work has the LPPL maintenance status "maintained". --%% --%% The Current Maintainer of this work is Johannes Braams. --%% --%% This file may only be distributed together with a copy of the --%% supertabular package. You may however distribute the supertabular package --%% without such generated files. --%% --%% The list of all files belonging to the supertabular package is --%% given in the file `manifest.txt. --%% --%% The list of derived (unpacked) files belonging to the distribution --%% and covered by LPPL is defined by the unpacking scripts (with --%% extension .ins) which are part of the distribution. --%% Sourcefile `supertabular.dtx'. --%% --%% Copyright (C) 1988 by Theo Jurriens --%% Copyright (C) 1990-2004 by Johannes Braams texniek at braams.cistron.nl --%% Kersengaarde 33 --%% 2723 BP Zoetermeer NL --%% all rights reserved. --%% --%% --\NeedsTeXFormat{LaTeX2e} --\ProvidesPackage{supertabular} -- [2004/02/20 v4.1e the supertabular environment] --\newcount\c@tracingst --\DeclareOption{errorshow}{\c@tracingst\z@} --\DeclareOption{pageshow}{\c@tracingst\tw@} --\DeclareOption{debugshow}{\c@tracingst5\relax} --\ProcessOptions --\newif\if@topcaption \@topcaptiontrue --\def\topcaption{\@topcaptiontrue\tablecaption} --\def\bottomcaption{\@topcaptionfalse\tablecaption} --\long\def\tablecaption{% -- \refstepcounter{table}\@dblarg{\@xtablecaption}} --\long\def\@xtablecaption[#1]#2{% -- \long\gdef\@process@tablecaption{\ST@caption{table}[#1]{#2}}} --\global\let\@process@tablecaption\relax --\newif\ifST@star --\newif\ifST@mp --\newdimen\ST@wd --\newskip\ST@rightskip --\newskip\ST@leftskip --\newskip\ST@parfillskip --\long\def\ST@caption#1[#2]#3{\par% -- \addcontentsline{\csname ext@#1\endcsname}{#1}% -- {\protect\numberline{% -- \csname the#1\endcsname}{\ignorespaces #2}} -- \begingroup -- \@parboxrestore -- \normalsize -- \if@topcaption \vskip -10\p@ \fi -- \@makecaption{\csname fnum@#1\endcsname}{\ignorespaces #3}\par -- \if@topcaption \vskip 10\p@ \fi -- \endgroup} --\newcommand\tablehead[1]{% -- \gdef\@tablehead{% -- \noalign{% -- \global\let\@savcr=\\ -- \global\let\\=\org@tabularcr}% -- #1% -- \noalign{\global\let\\=\@savcr}}} --\tablehead{} --\newcommand\tablefirsthead[1]{\gdef\@table@first@head{#1}} --\newcommand\tabletail[1]{% -- \gdef\@tabletail{% -- \noalign{% -- \global\let\@savcr=\\ -- \global\let\\=\org@tabularcr}% -- #1% -- \noalign{\global\let\\=\@savcr}}} --\tabletail{} --\newcommand\tablelasttail[1]{\gdef\@table@last@tail{#1}} --\newcommand\sttraceon{\c@tracingst5\relax} --\newcommand\sttraceoff{\c@tracingst\z@} --\newcommand\ST@trace[2]{% -- \ifnum\c@tracingst>#1\relax -- \GenericWarning -- {(supertabular)\@spaces\@spaces} -- {Package supertabular: #2}% -- \fi -- } --\newdimen\ST@pageleft --\newcommand*\shrinkheight[1]{% -- \noalign{\global\advance\ST@pageleft-#1\relax}} --\newcommand*\setSTheight[1]{% -- \noalign{\global\ST@pageleft=#1\relax}} --\newdimen\ST@headht --\newdimen\ST@tailht --\newdimen\ST@pagesofar --\newdimen\ST@pboxht --\newdimen\ST@lineht --\newdimen\ST@stretchht --\newdimen\ST@prevht --\newdimen\ST@toadd --\newdimen\ST@dimen --\newbox\ST@pbox --\def\ST@tabularcr{% -- {\ifnum0=`}\fi -- \@ifstar{\ST@xtabularcr}{\ST@xtabularcr}} --\def\ST@xtabularcr{% -- \@ifnextchar[%] -- {\ST@argtabularcr}% -- {\ifnum0=`{\fi}\cr\ST@cr}} --\def\ST@argtabularcr[#1]{% -- \ifnum0=`{\fi}% -- \ifdim #1>\z@ -- \unskip\ST@xargarraycr{#1} -- \else -- \ST@yargarraycr{#1}% -- \fi} --\def\ST@xargarraycr#1{% -- \@tempdima #1\advance\@tempdima \dp \@arstrutbox -- \vrule \@height\z@ \@depth\@tempdima \@width\z@ \cr -- \noalign{\global\ST@toadd=#1}\ST@cr} --\def\ST@yargarraycr#1{% -- \cr\noalign{\vskip #1\global\ST@toadd=#1}\ST@cr} --\def\ST@startpbox#1{% -- \setbox\ST@pbox\vtop\bgroup\hsize#1\@arrayparboxrestore} --\def\ST@astartpbox#1{% -- \bgroup\hsize#1% -- \setbox\ST@pbox\vtop\bgroup\hsize#1\@arrayparboxrestore} --\def\ST@endpbox{% -- \@finalstrut\@arstrutbox\par\egroup -- \ST@dimen=\ht\ST@pbox -- \advance\ST@dimen by \dp\ST@pbox -- \ifnum\ST@pboxht<\ST@dimen -- \global\ST@pboxht=\ST@dimen -- \fi -- \ST@dimen=\z@ -- \box\ST@pbox\hfil} --\def\ST@aendpbox{% -- \@finalstrut\@arstrutbox\par\egroup -- \ST@dimen=\ht\ST@pbox -- \advance\ST@dimen by \dp\ST@pbox -- \ifnum\ST@pboxht<\ST@dimen -- \global\ST@pboxht=\ST@dimen -- \fi -- \ST@dimen=\z@ -- \unvbox\ST@pbox\egroup\hfil} --\def\estimate@lineht{% -- \ST@lineht=\arraystretch \baslineskp -- \global\advance\ST@lineht by 1\p@ -- \ST@stretchht\ST@lineht\advance\ST@stretchht-\baslineskp -- \ifdim\ST@stretchht<\z@\ST@stretchht\z@\fi -- \ST@trace\tw@{Average line height: \the\ST@lineht}% -- \ST@trace\tw@{Stretched line height: \the\ST@stretchht}% -- } --\def\@calfirstpageht{% -- \ST@trace\tw@{Calculating height of tabular on first page}% -- \global\ST@pagesofar\pagetotal -- \global\ST@pageleft\@colroom -- \ST@trace\tw@{Height of text = \the\pagetotal; \MessageBreak -- Height of page = \the\ST@pageleft}% -- \if@twocolumn -- \ST@trace\tw@{two column mode}% -- \if@firstcolumn -- \ST@trace\tw@{First column}% -- \ifnum\ST@pagesofar > \ST@pageleft -- \global\ST@pageleft=2\ST@pageleft -- \ifnum\ST@pagesofar > \ST@pageleft -- \newpage\@calnextpageht -- \ST@trace\tw@{starting new page}% -- \else -- \ST@trace\tw@{Second column}% -- \global\advance\ST@pageleft -\ST@pagesofar -- \global\advance\ST@pageleft -\@colroom -- \fi -- \else -- \global\advance\ST@pageleft by -\ST@pagesofar -- \global\ST@pagesofar\z@ -- \fi -- \else -- \ST@trace\tw@{Second column} -- \ifnum\ST@pagesofar > \ST@pageleft -- \ST@trace\tw@{starting new page}% -- \newpage\@calnextpageht -- \else -- \global\advance\ST@pageleft by -\ST@pagesofar -- \global\ST@pagesofar\z@ -- \fi -- \fi -- \else -- \ST@trace\tw@{one column mode}% -- \ifnum\ST@pagesofar > \ST@pageleft -- \ST@trace\tw@{starting new page}% -- \newpage\@calnextpageht -- \else -- \global\advance\ST@pageleft by -\ST@pagesofar -- \global\ST@pagesofar\z@ -- \fi -- \fi -- \ST@trace\tw@{Available height: \the\ST@pageleft}% -- \ifx\@@tablehead\@empty -- \ST@headht=\z@ -- \else -- \setbox\@tempboxa=\vbox{\@arrayparboxrestore -- \ST@restore -- \expandafter\tabular\expandafter{\ST@tableformat}% -- \@@tablehead\endtabular}% -- \ST@headht=\ht\@tempboxa\advance\ST@headht\dp\@tempboxa -- \fi -- \ST@trace\tw@{Height of head: \the\ST@headht}% -- \ifx\@tabletail\@empty -- \ST@tailht=\z@ -- \else -- \setbox\@tempboxa=\vbox{\@arrayparboxrestore -- \ST@restore -- \expandafter\tabular\expandafter{\ST@tableformat} -- \@tabletail\endtabular} -- \ST@tailht=\ht\@tempboxa\advance\ST@tailht\dp\@tempboxa -- \fi -- \advance\ST@tailht by \ST@lineht -- \ST@trace\tw@{Height of tail: \the\ST@tailht}% -- \ST@trace\tw@{Maximum height of tabular: \the\ST@pageleft}% -- \@tempdima\ST@headht -- \advance\@tempdima\ST@lineht -- \advance\@tempdima\ST@tailht -- \ST@trace\tw@{Minimum height of tabular: \the\@tempdima}% -- \ifnum\@tempdima>\ST@pageleft -- \ST@trace\tw@{starting new page}% -- \newpage\@calnextpageht -- \fi --} --\def\@calnextpageht{% -- \ST@trace\tw@{Calculating height of tabular on next page}% -- \global\ST@pageleft\@colroom -- \global\ST@pagesofar=\z@ -- \ST@trace\tw@{Maximum height of tabular: \the\ST@pageleft}% -- } --\def\x@supertabular{% -- \let\org@tabular\tabular -- \let\tabular\inner@tabular -- \expandafter\let -- \csname org@tabular*\expandafter\endcsname -- \csname tabular*\endcsname -- \expandafter\let\csname tabular*\expandafter\endcsname -- \csname inner@tabular*\endcsname -- \if@topcaption \@process@tablecaption \fi -- \global\let\@oldcr=\\ -- \def\baslineskp{\baselineskip}% -- \ifx\undefined\@classix -- \let\org@tabularcr\@tabularcr -- \let\@tabularcr\ST@tabularcr -- \let\org@startpbox=\@startpbox -- \let\org@endpbox=\@endpbox -- \let\@@startpbox=\ST@startpbox -- \let\@@endpbox=\ST@endpbox -- \else -- \let\org@tabularcr\@arraycr -- \let\@arraycr\ST@tabularcr -- \let\org@startpbox=\@startpbox -- \let\org@endpbox=\@endpbox -- \let\@startpbox=\ST@astartpbox -- \let\@endpbox=\ST@aendpbox -- \fi -- \ifx\@table@first@head\undefined -- \let\@@tablehead=\@tablehead -- \else -- \let\@@tablehead=\@table@first@head -- \fi -- \let\ST@skippage\ST@skipfirstpart -- \estimate@lineht -- \@calfirstpageht -- \noindent -- } --\def\supertabular{% -- \@ifnextchar[{\@supertabular}%] -- {\@supertabular[]}} --\def\@supertabular[#1]#2{% -- \def\ST@tableformat{#2}% -- \ST@trace\tw@{Starting a new supertabular}% -- \global\ST@starfalse -- \global\ST@mpfalse -- \x@supertabular -- \expandafter\org@tabular\expandafter{\ST@tableformat}% -- \@@tablehead} --\@namedef{supertabular*}#1{% -- \@ifnextchar[{\@nameuse{@supertabular*}{#1}}% -- {\@nameuse{@supertabular*}{#1}[]}%] -- } --\@namedef{@supertabular*}#1[#2]#3{% -- \ST@trace\tw@{Starting a new supertabular*}% -- \def\ST@tableformat{#3}% -- \ST@wd=#1\relax -- \global\ST@startrue -- \global\ST@mpfalse -- \x@supertabular -- \expandafter\csname org@tabular*\expandafter\endcsname -- \expandafter{\expandafter\ST@wd\expandafter}% -- \expandafter{\ST@tableformat}% -- \@@tablehead}% --\def\mpsupertabular{% -- \@ifnextchar[{\@mpsupertabular}%] -- {\@mpsupertabular[]}} --\def\@mpsupertabular[#1]#2{% -- \def\ST@tableformat{#2}% -- \ST@trace\tw@{Starting a new mpsupertabular}% -- \global\ST@starfalse -- \global\ST@mptrue -- \ST@rightskip \rightskip -- \ST@leftskip \leftskip -- \ST@parfillskip \parfillskip -- \x@supertabular -- \minipage{\columnwidth}% -- \parfillskip\ST@parfillskip -- \rightskip \ST@rightskip -- \leftskip \ST@leftskip -- \noindent\expandafter\org@tabular\expandafter{\ST@tableformat}% -- \@@tablehead} --\@namedef{mpsupertabular*}#1{% -- \@ifnextchar[{\@nameuse{@mpsupertabular*}{#1}}% -- {\@nameuse{@mpsupertabular*}{#1}[]}%] -- } --\@namedef{@mpsupertabular*}#1[#2]#3{% -- \ST@trace\tw@{Starting a new mpsupertabular*}% -- \def\ST@tableformat{#3}% -- \ST@wd=#1\relax -- \global\ST@startrue -- \global\ST@mptrue -- \ST@rightskip \rightskip -- \ST@leftskip \leftskip -- \ST@parfillskip \parfillskip -- \x@supertabular -- \minipage{\columnwidth}% -- \parfillskip\ST@parfillskip -- \rightskip \ST@rightskip -- \leftskip \ST@leftskip -- \noindent\expandafter\csname org@tabular*\expandafter\endcsname -- \expandafter{\expandafter\ST@wd\expandafter}% -- \expandafter{\ST@tableformat}% -- \@@tablehead}% --\def\endsupertabular{% -- \ifx\@table@last@tail\undefined -- \@tabletail -- \else -- \@table@last@tail -- \fi -- \csname endtabular\ifST@star*\fi\endcsname -- \ST@restore -- \if@topcaption -- \else -- \@process@tablecaption -- \@topcaptiontrue -- \fi -- \global\let\\\@oldcr -- \global\let\@process@tablecaption\relax -- \ST@trace\tw@{Ended a supertabular\ifST@star*\fi}% -- } --\expandafter\let\csname endsupertabular*\endcsname\endsupertabular --\def\endmpsupertabular{% -- \ifx\@table@last@tail\undefined -- \@tabletail -- \else -- \@table@last@tail -- \fi -- \csname endtabular\ifST@star*\fi\endcsname -- \endminipage -- \ST@restore -- \if@topcaption -- \else -- \@process@tablecaption -- \@topcaptiontrue -- \fi -- \global\let\\\@oldcr -- \global\let\@process@tablecaption\relax -- \ST@trace\tw@{Ended a mpsupertabular\ifST@star*\fi}% -- } --\expandafter\let\csname endmpsupertabular*\endcsname\endmpsupertabular --\def\ST@restore{% -- \ifx\undefined\@classix -- \let\@tabularcr\org@tabularcr -- \else -- \let\@arraycr\org@tabularcr -- \fi -- \let\@startpbox\org@startpbox -- \let\@endpbox\org@endpbox -- } --\def\inner@tabular{% -- \ST@restore -- \let\\\@oldcr -- \noindent -- \org@tabular} --\@namedef{inner@tabular*}{% -- \ST@restore -- \let\\\@oldcr -- \noindent -- \csname org@tabular*\endcsname} --\def\ST@cr{% -- \noalign{% -- \ifnum\ST@pboxht<\ST@lineht -- \global\advance\ST@pageleft -\ST@lineht -- \global\ST@prevht\ST@lineht -- \else -- \ST@trace\thr@@{Added par box with height \the\ST@pboxht}% -- \global\advance\ST@pageleft -\ST@pboxht -- \global\advance\ST@pageleft -0.1\ST@pboxht -- \global\advance\ST@pageleft -\ST@stretchht -- \global\ST@prevht\ST@pboxht -- \global\ST@pboxht\z@ -- \fi -- \global\advance\ST@pageleft -\ST@toadd -- \global\ST@toadd=\z@ -- \ST@trace\thr@@{Space left for tabular: \the\ST@pageleft}% -- } -- \noalign{\global\let\ST@next\@empty}% -- \ifnum\ST@pageleft<\z@ -- \ST@skippage -- \else -- \noalign{\global\@tempdima\ST@tailht -- \global\advance\@tempdima\ST@prevht -- \ifST@mp -- \ifvoid\@mpfootins\else -- \global\advance\@tempdima\ht\@mpfootins -- \global\advance\@tempdima 3pt -- \fi -- \fi} -- \ifnum\ST@pageleft<\@tempdima -- \ST@newpage -- \fi -- \fi -- \ST@next} --\def\ST@skipfirstpart{% -- \noalign{% -- \ST@trace\tw@{Tabular too high, moving to next page}% -- \global\advance\ST@pageleft\pagetotal -- \global\ST@pagesofar\z@ -- \newpage -- \global\let\ST@skippage\ST@newpage -- }} --\def\ST@newpage{% -- \noalign{\ST@trace\tw@{Starting new page, writing tail}}% -- \@tabletail -- \ifST@star -- \csname endtabular*\endcsname -- \else -- \endtabular -- \fi -- \ifST@mp -- \endminipage -- \fi -- \global\let\ST@skippage\ST@newpage -- \newpage\@calnextpageht -- \let\ST@next\@tablehead -- \ST@trace\tw@{writing head}% -- \ifST@mp -- \noindent\minipage{\columnwidth}% -- \parfillskip\ST@parfillskip -- \rightskip \ST@rightskip -- \leftskip \ST@leftskip -- \fi -- \noindent -- \ifST@star -- \expandafter\csname org@tabular*\expandafter\endcsname -- \expandafter{\expandafter\ST@wd\expandafter}% -- \expandafter{\ST@tableformat}% -- \else -- \expandafter\org@tabular\expandafter{\ST@tableformat}% -- \fi} --\endinput --%% --%% End of file `supertabular.sty'. -diff --git a/scipy/linalg/src/id_dist/src/dfft.f b/scipy/linalg/src/id_dist/src/dfft.f -deleted file mode 100644 -index b1b1b3206..000000000 ---- a/scipy/linalg/src/id_dist/src/dfft.f -+++ /dev/null -@@ -1,3014 +0,0 @@ --C --C FFTPACK --C --C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * --C --C VERSION 4 APRIL 1985 --C --C A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE FAST FOURIER --C TRANSFORM OF PERIODIC AND OTHER SYMMETRIC SEQUENCES --C --C BY --C --C PAUL N SWARZTRAUBER --C --C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH BOULDER,COLORADO 80307 --C --C WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION --C --C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * --C --C --C THIS PACKAGE CONSISTS OF PROGRAMS WHICH PERFORM FAST FOURIER --C TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND --C CERTAIN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW. --C --C 1. DFFTI INITIALIZE DFFTF AND DFFTB --C 2. DFFTF FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE --C 3. DFFTB BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY --C --C 4. DZFFTI INITIALIZE DZFFTF AND DZFFTB --C 5. DZFFTF A SIMPLIFIED REAL PERIODIC FORWARD TRANSFORM --C 6. DZFFTB A SIMPLIFIED REAL PERIODIC BACKWARD TRANSFORM --C --C 7. DSINTI INITIALIZE DSINT --C 8. DSINT SINE TRANSFORM OF A REAL ODD SEQUENCE --C --C 9. DCOSTI INITIALIZE DCOST --C 10. DCOST COSINE TRANSFORM OF A REAL EVEN SEQUENCE --C --C 11. DSINQI INITIALIZE DSINQF AND DSINQB --C 12. DSINQF FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS --C 13. DSINQB UNNORMALIZED INVERSE OF DSINQF --C --C 14. DCOSQI INITIALIZE DCOSQF AND DCOSQB --C 15. DCOSQF FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS --C 16. DCOSQB UNNORMALIZED INVERSE OF DCOSQF --C --C 17. ZFFTI INITIALIZE ZFFTF AND ZFFTB --C 18. ZFFTF FORWARD TRANSFORM OF A COMPLEX PERIODIC SEQUENCE --C 19. ZFFTB UNNORMALIZED INVERSE OF ZFFTF --C --C --C ****************************************************************** --C --C SUBROUTINE DFFTI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C BOTH DFFTF AND DFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. --C THE SAME WORK ARRAY CAN BE USED FOR BOTH DFFTF AND DFFTB --C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS --C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF --C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF DFFTF OR DFFTB. --C --C ****************************************************************** --C --C SUBROUTINE DFFTF(N,R,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL --C PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED --C BELOW AT OUTPUT PARAMETER R. --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED --C --C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE --C TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. --C IN THE PROGRAM THAT CALLS DFFTF. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DFFTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C THE SAME WSAVE ARRAY CAN BE USED BY DFFTF AND DFFTB. --C --C --C OUTPUT PARAMETERS --C --C R R(1) = THE SUM FROM I=1 TO I=N OF R(I) --C --C IF N IS EVEN SET L =N/2 , IF N IS ODD SET L = (N+1)/2 --C --C THEN FOR K = 2,...,L --C --C R(2*K-2) = THE SUM FROM I = 1 TO I = N OF --C --C R(I)*COS((K-1)*(I-1)*2*PI/N) --C --C R(2*K-1) = THE SUM FROM I = 1 TO I = N OF --C --C -R(I)*SIN((K-1)*(I-1)*2*PI/N) --C --C IF N IS EVEN --C --C R(N) = THE SUM FROM I = 1 TO I = N OF --C --C (-1)**(I-1)*R(I) --C --C ***** NOTE --C THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF DFFTF --C FOLLOWED BY A CALL OF DFFTB WILL MULTIPLY THE INPUT --C SEQUENCE BY N. --C --C WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN --C CALLS OF DFFTF OR DFFTB. --C --C --C ****************************************************************** --C --C SUBROUTINE DFFTB(N,R,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS --C FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED --C BELOW AT OUTPUT PARAMETER R. --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED --C --C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE --C TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. --C IN THE PROGRAM THAT CALLS DFFTB. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DFFTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C THE SAME WSAVE ARRAY CAN BE USED BY DFFTF AND DFFTB. --C --C --C OUTPUT PARAMETERS --C --C R FOR N EVEN AND FOR I = 1,...,N --C --C R(I) = R(1)+(-1)**(I-1)*R(N) --C --C PLUS THE SUM FROM K=2 TO K=N/2 OF --C --C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) --C --C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) --C --C FOR N ODD AND FOR I = 1,...,N --C --C R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF --C --C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) --C --C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) --C --C ***** NOTE --C THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF DFFTF --C FOLLOWED BY A CALL OF DFFTB WILL MULTIPLY THE INPUT --C SEQUENCE BY N. --C --C WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN --C CALLS OF DFFTB OR DFFTF. --C --C --C ****************************************************************** --C --C SUBROUTINE DZFFTI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DZFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C BOTH DZFFTF AND DZFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C THE SAME WORK ARRAY CAN BE USED FOR BOTH DZFFTF AND DZFFTB --C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS --C ARE REQUIRED FOR DIFFERENT VALUES OF N. --C --C --C ****************************************************************** --C --C SUBROUTINE DZFFTF(N,R,AZERO,A,B,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DZFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL --C PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED --C BELOW AT OUTPUT PARAMETERS AZERO,A AND B. DZFFTF IS A SIMPLIFIED --C BUT SLOWER VERSION OF DFFTF. --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD --C IS MUST EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. --C --C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE --C TO BE TRANSFORMED. R IS NOT DESTROYED. --C --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C IN THE PROGRAM THAT CALLS DZFFTF. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DZFFTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C THE SAME WSAVE ARRAY CAN BE USED BY DZFFTF AND DZFFTB. --C --C OUTPUT PARAMETERS --C --C AZERO THE SUM FROM I=1 TO I=N OF R(I)/N --C --C A,B FOR N EVEN B(N/2)=0. AND A(N/2) IS THE SUM FROM I=1 TO --C I=N OF (-1)**(I-1)*R(I)/N --C --C FOR N EVEN DEFINE KMAX=N/2-1 --C FOR N ODD DEFINE KMAX=(N-1)/2 --C --C THEN FOR K=1,...,KMAX --C --C A(K) EQUALS THE SUM FROM I=1 TO I=N OF --C --C 2./N*R(I)*COS(K*(I-1)*2*PI/N) --C --C B(K) EQUALS THE SUM FROM I=1 TO I=N OF --C --C 2./N*R(I)*SIN(K*(I-1)*2*PI/N) --C --C --C ****************************************************************** --C --C SUBROUTINE DZFFTB(N,R,AZERO,A,B,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DZFFTB COMPUTES A REAL PERODIC SEQUENCE FROM ITS --C FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS --C DEFINED BELOW AT OUTPUT PARAMETER R. DZFFTB IS A SIMPLIFIED --C BUT SLOWER VERSION OF DFFTB. --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE OUTPUT ARRAY R. THE METHOD IS MOST --C EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. --C --C AZERO THE CONSTANT FOURIER COEFFICIENT --C --C A,B ARRAYS WHICH CONTAIN THE REMAINING FOURIER COEFFICIENTS --C THESE ARRAYS ARE NOT DESTROYED. --C --C THE LENGTH OF THESE ARRAYS DEPENDS ON WHETHER N IS EVEN OR --C ODD. --C --C IF N IS EVEN N/2 LOCATIONS ARE REQUIRED --C IF N IS ODD (N-1)/2 LOCATIONS ARE REQUIRED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C IN THE PROGRAM THAT CALLS DZFFTB. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DZFFTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C THE SAME WSAVE ARRAY CAN BE USED BY DZFFTF AND DZFFTB. --C --C --C OUTPUT PARAMETERS --C --C R IF N IS EVEN DEFINE KMAX=N/2 --C IF N IS ODD DEFINE KMAX=(N-1)/2 --C --C THEN FOR I=1,...,N --C --C R(I)=AZERO PLUS THE SUM FROM K=1 TO K=KMAX OF --C --C A(K)*COS(K*(I-1)*2*PI/N)+B(K)*SIN(K*(I-1)*2*PI/N) --C --C ********************* COMPLEX NOTATION ************************** --C --C FOR J=1,...,N --C --C R(J) EQUALS THE SUM FROM K=-KMAX TO K=KMAX OF --C --C C(K)*EXP(I*K*(J-1)*2*PI/N) --C --C WHERE --C --C C(K) = .5*CMPLX(A(K),-B(K)) FOR K=1,...,KMAX --C --C C(-K) = CONJG(C(K)) --C --C C(0) = AZERO --C --C AND I=SQRT(-1) --C --C *************** AMPLITUDE - PHASE NOTATION *********************** --C --C FOR I=1,...,N --C --C R(I) EQUALS AZERO PLUS THE SUM FROM K=1 TO K=KMAX OF --C --C ALPHA(K)*COS(K*(I-1)*2*PI/N+BETA(K)) --C --C WHERE --C --C ALPHA(K) = SQRT(A(K)*A(K)+B(K)*B(K)) --C --C COS(BETA(K))=A(K)/ALPHA(K) --C --C SIN(BETA(K))=-B(K)/ALPHA(K) --C --C ****************************************************************** --C --C SUBROUTINE DSINTI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DSINTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C SUBROUTINE DSINT. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N+1 IS A PRODUCT OF SMALL PRIMES. --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WITH AT LEAST INT(2.5*N+15) LOCATIONS. --C DIFFERENT WSAVE ARRAYS ARE REQUIRED FOR DIFFERENT VALUES --C OF N. THE CONTENTS OF WSAVE MUST NOT BE CHANGED BETWEEN --C CALLS OF DSINT. --C --C ****************************************************************** --C --C SUBROUTINE DSINT(N,X,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DSINT COMPUTES THE DISCRETE FOURIER SINE TRANSFORM --C OF AN ODD SEQUENCE X(I). THE TRANSFORM IS DEFINED BELOW AT --C OUTPUT PARAMETER X. --C --C DSINT IS THE UNNORMALIZED INVERSE OF ITSELF SINCE A CALL OF DSINT --C FOLLOWED BY ANOTHER CALL OF DSINT WILL MULTIPLY THE INPUT SEQUENCE --C X BY 2*(N+1). --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DSINT MUST BE --C INITIALIZED BY CALLING SUBROUTINE DSINTI(N,WSAVE). --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N+1 IS THE PRODUCT OF SMALL PRIMES. --C --C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED --C --C --C WSAVE A WORK ARRAY WITH DIMENSION AT LEAST INT(2.5*N+15) --C IN THE PROGRAM THAT CALLS DSINT. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DSINTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C --C OUTPUT PARAMETERS --C --C X FOR I=1,...,N --C --C X(I)= THE SUM FROM K=1 TO K=N --C --C 2*X(K)*SIN(K*I*PI/(N+1)) --C --C A CALL OF DSINT FOLLOWED BY ANOTHER CALL OF --C DSINT WILL MULTIPLY THE SEQUENCE X BY 2*(N+1). --C HENCE DSINT IS THE UNNORMALIZED INVERSE --C OF ITSELF. --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE --C DESTROYED BETWEEN CALLS OF DSINT. --C --C ****************************************************************** --C --C SUBROUTINE DCOSTI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DCOSTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C SUBROUTINE DCOST. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N-1 IS A PRODUCT OF SMALL PRIMES. --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C DIFFERENT WSAVE ARRAYS ARE REQUIRED FOR DIFFERENT VALUES --C OF N. THE CONTENTS OF WSAVE MUST NOT BE CHANGED BETWEEN --C CALLS OF DCOST. --C --C ****************************************************************** --C --C SUBROUTINE DCOST(N,X,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DCOST COMPUTES THE DISCRETE FOURIER COSINE TRANSFORM --C OF AN EVEN SEQUENCE X(I). THE TRANSFORM IS DEFINED BELOW AT OUTPUT --C PARAMETER X. --C --C DCOST IS THE UNNORMALIZED INVERSE OF ITSELF SINCE A CALL OF DCOST --C FOLLOWED BY ANOTHER CALL OF DCOST WILL MULTIPLY THE INPUT SEQUENCE --C X BY 2*(N-1). THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DCOST MUST BE --C INITIALIZED BY CALLING SUBROUTINE DCOSTI(N,WSAVE). --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE SEQUENCE X. N MUST BE GREATER THAN 1. --C THE METHOD IS MOST EFFICIENT WHEN N-1 IS A PRODUCT OF --C SMALL PRIMES. --C --C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 --C IN THE PROGRAM THAT CALLS DCOST. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DCOSTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C --C OUTPUT PARAMETERS --C --C X FOR I=1,...,N --C --C X(I) = X(1)+(-1)**(I-1)*X(N) --C --C + THE SUM FROM K=2 TO K=N-1 --C --C 2*X(K)*COS((K-1)*(I-1)*PI/(N-1)) --C --C A CALL OF DCOST FOLLOWED BY ANOTHER CALL OF --C DCOST WILL MULTIPLY THE SEQUENCE X BY 2*(N-1) --C HENCE DCOST IS THE UNNORMALIZED INVERSE --C OF ITSELF. --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE --C DESTROYED BETWEEN CALLS OF DCOST. --C --C ****************************************************************** --C --C SUBROUTINE DSINQI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DSINQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C BOTH DSINQF AND DSINQB. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C THE SAME WORK ARRAY CAN BE USED FOR BOTH DSINQF AND DSINQB --C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS --C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF --C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF DSINQF OR DSINQB. --C --C ****************************************************************** --C --C SUBROUTINE DSINQF(N,X,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DSINQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER --C WAVE DATA. THAT IS , DSINQF COMPUTES THE COEFFICIENTS IN A SINE --C SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM --C IS DEFINED BELOW AT OUTPUT PARAMETER X. --C --C DSINQB IS THE UNNORMALIZED INVERSE OF DSINQF SINCE A CALL OF DSINQF --C FOLLOWED BY A CALL OF DSINQB WILL MULTIPLY THE INPUT SEQUENCE X --C BY 4*N. --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DSINQF MUST BE --C INITIALIZED BY CALLING SUBROUTINE DSINQI(N,WSAVE). --C --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C --C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C IN THE PROGRAM THAT CALLS DSINQF. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DSINQI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C --C OUTPUT PARAMETERS --C --C X FOR I=1,...,N --C --C X(I) = (-1)**(I-1)*X(N) --C --C + THE SUM FROM K=1 TO K=N-1 OF --C --C 2*X(K)*SIN((2*I-1)*K*PI/(2*N)) --C --C A CALL OF DSINQF FOLLOWED BY A CALL OF --C DSINQB WILL MULTIPLY THE SEQUENCE X BY 4*N. --C THEREFORE DSINQB IS THE UNNORMALIZED INVERSE --C OF DSINQF. --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT --C BE DESTROYED BETWEEN CALLS OF DSINQF OR DSINQB. --C --C ****************************************************************** --C --C SUBROUTINE DSINQB(N,X,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DSINQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER --C WAVE DATA. THAT IS , DSINQB COMPUTES A SEQUENCE FROM ITS --C REPRESENTATION IN TERMS OF A SINE SERIES WITH ODD WAVE NUMBERS. --C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. --C --C DSINQF IS THE UNNORMALIZED INVERSE OF DSINQB SINCE A CALL OF DSINQB --C FOLLOWED BY A CALL OF DSINQF WILL MULTIPLY THE INPUT SEQUENCE X --C BY 4*N. --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DSINQB MUST BE --C INITIALIZED BY CALLING SUBROUTINE DSINQI(N,WSAVE). --C --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C --C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C IN THE PROGRAM THAT CALLS DSINQB. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DSINQI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C --C OUTPUT PARAMETERS --C --C X FOR I=1,...,N --C --C X(I)= THE SUM FROM K=1 TO K=N OF --C --C 4*X(K)*SIN((2K-1)*I*PI/(2*N)) --C --C A CALL OF DSINQB FOLLOWED BY A CALL OF --C DSINQF WILL MULTIPLY THE SEQUENCE X BY 4*N. --C THEREFORE DSINQF IS THE UNNORMALIZED INVERSE --C OF DSINQB. --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT --C BE DESTROYED BETWEEN CALLS OF DSINQB OR DSINQF. --C --C ****************************************************************** --C --C SUBROUTINE DCOSQI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DCOSQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C BOTH DCOSQF AND DCOSQB. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE ARRAY TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. --C THE SAME WORK ARRAY CAN BE USED FOR BOTH DCOSQF AND DCOSQB --C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS --C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF --C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF DCOSQF OR DCOSQB. --C --C ****************************************************************** --C --C SUBROUTINE DCOSQF(N,X,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DCOSQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER --C WAVE DATA. THAT IS , DCOSQF COMPUTES THE COEFFICIENTS IN A COSINE --C SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM --C IS DEFINED BELOW AT OUTPUT PARAMETER X --C --C DCOSQF IS THE UNNORMALIZED INVERSE OF DCOSQB SINCE A CALL OF DCOSQF --C FOLLOWED BY A CALL OF DCOSQB WILL MULTIPLY THE INPUT SEQUENCE X --C BY 4*N. --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DCOSQF MUST BE --C INITIALIZED BY CALLING SUBROUTINE DCOSQI(N,WSAVE). --C --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C --C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 --C IN THE PROGRAM THAT CALLS DCOSQF. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DCOSQI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C --C OUTPUT PARAMETERS --C --C X FOR I=1,...,N --C --C X(I) = X(1) PLUS THE SUM FROM K=2 TO K=N OF --C --C 2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N)) --C --C A CALL OF DCOSQF FOLLOWED BY A CALL OF --C DCOSQB WILL MULTIPLY THE SEQUENCE X BY 4*N. --C THEREFORE DCOSQB IS THE UNNORMALIZED INVERSE --C OF DCOSQF. --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT --C BE DESTROYED BETWEEN CALLS OF DCOSQF OR DCOSQB. --C --C ****************************************************************** --C --C SUBROUTINE DCOSQB(N,X,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE DCOSQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER --C WAVE DATA. THAT IS , DCOSQB COMPUTES A SEQUENCE FROM ITS --C REPRESENTATION IN TERMS OF A COSINE SERIES WITH ODD WAVE NUMBERS. --C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. --C --C DCOSQB IS THE UNNORMALIZED INVERSE OF DCOSQF SINCE A CALL OF DCOSQB --C FOLLOWED BY A CALL OF DCOSQF WILL MULTIPLY THE INPUT SEQUENCE X --C BY 4*N. --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DCOSQB MUST BE --C INITIALIZED BY CALLING SUBROUTINE DCOSQI(N,WSAVE). --C --C --C INPUT PARAMETERS --C --C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD --C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. --C --C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED --C --C WSAVE A WORK ARRAY THAT MUST BE DIMENSIONED AT LEAST 3*N+15 --C IN THE PROGRAM THAT CALLS DCOSQB. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE DCOSQI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C --C OUTPUT PARAMETERS --C --C X FOR I=1,...,N --C --C X(I)= THE SUM FROM K=1 TO K=N OF --C --C 4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N)) --C --C A CALL OF DCOSQB FOLLOWED BY A CALL OF --C DCOSQF WILL MULTIPLY THE SEQUENCE X BY 4*N. --C THEREFORE DCOSQF IS THE UNNORMALIZED INVERSE --C OF DCOSQB. --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT --C BE DESTROYED BETWEEN CALLS OF DCOSQB OR DCOSQF. --C --C ****************************************************************** --C --C SUBROUTINE ZFFTI(N,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE ZFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN --C BOTH ZFFTF AND ZFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH --C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND --C STORED IN WSAVE. --C --C INPUT PARAMETER --C --C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED --C --C OUTPUT PARAMETER --C --C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15 --C THE SAME WORK ARRAY CAN BE USED FOR BOTH ZFFTF AND ZFFTB --C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS --C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF --C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF ZFFTF OR ZFFTB. --C --C ****************************************************************** --C --C SUBROUTINE ZFFTF(N,C,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE ZFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER --C TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , ZFFTF COMPUTES --C THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE. --C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C. --C --C THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM --C THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF ZFFTF --C FOLLOWED BY A CALL OF ZFFTB WILL MULTIPLY THE SEQUENCE BY N. --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE ZFFTF MUST BE --C INITIALIZED BY CALLING SUBROUTINE ZFFTI(N,WSAVE). --C --C INPUT PARAMETERS --C --C --C N THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS --C MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N --C --C C A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE --C --C WSAVE A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15 --C IN THE PROGRAM THAT CALLS ZFFTF. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE ZFFTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C THE SAME WSAVE ARRAY CAN BE USED BY ZFFTF AND ZFFTB. --C --C OUTPUT PARAMETERS --C --C C FOR J=1,...,N --C --C C(J)=THE SUM FROM K=1,...,N OF --C --C C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) --C --C WHERE I=SQRT(-1) --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE --C DESTROYED BETWEEN CALLS OF SUBROUTINE ZFFTF OR ZFFTB --C --C ****************************************************************** --C --C SUBROUTINE ZFFTB(N,C,WSAVE) --C --C ****************************************************************** --C --C SUBROUTINE ZFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER --C TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , ZFFTB COMPUTES --C A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS. --C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C. --C --C A CALL OF ZFFTF FOLLOWED BY A CALL OF ZFFTB WILL MULTIPLY THE --C SEQUENCE BY N. --C --C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE ZFFTB MUST BE --C INITIALIZED BY CALLING SUBROUTINE ZFFTI(N,WSAVE). --C --C INPUT PARAMETERS --C --C --C N THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS --C MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. --C --C C A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE --C --C WSAVE A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15 --C IN THE PROGRAM THAT CALLS ZFFTB. THE WSAVE ARRAY MUST BE --C INITIALIZED BY CALLING SUBROUTINE ZFFTI(N,WSAVE) AND A --C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT --C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE --C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT --C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. --C THE SAME WSAVE ARRAY CAN BE USED BY ZFFTF AND ZFFTB. --C --C OUTPUT PARAMETERS --C --C C FOR J=1,...,N --C --C C(J)=THE SUM FROM K=1,...,N OF --C --C C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) --C --C WHERE I=SQRT(-1) --C --C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE --C DESTROYED BETWEEN CALLS OF SUBROUTINE ZFFTF OR ZFFTB --C --C --C --C ["SEND INDEX FOR VFFTPK" DESCRIBES A VECTORIZED VERSION OF FFTPACK] --C --C --C -- -- SUBROUTINE ZFFTB1 (N,C,CH,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) -- NF = IFAC(2) -- NA = 0 -- L1 = 1 -- IW = 1 -- DO 116 K1=1,NF -- IP = IFAC(K1+2) -- L2 = IP*L1 -- IDO = N/L2 -- IDOT = IDO+IDO -- IDL1 = IDOT*L1 -- IF (IP .NE. 4) GO TO 103 -- IX2 = IW+IDOT -- IX3 = IX2+IDOT -- IF (NA .NE. 0) GO TO 101 -- CALL DPASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) -- GO TO 102 -- 101 CALL DPASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) -- 102 NA = 1-NA -- GO TO 115 -- 103 IF (IP .NE. 2) GO TO 106 -- IF (NA .NE. 0) GO TO 104 -- CALL DPASSB2 (IDOT,L1,C,CH,WA(IW)) -- GO TO 105 -- 104 CALL DPASSB2 (IDOT,L1,CH,C,WA(IW)) -- 105 NA = 1-NA -- GO TO 115 -- 106 IF (IP .NE. 3) GO TO 109 -- IX2 = IW+IDOT -- IF (NA .NE. 0) GO TO 107 -- CALL DPASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) -- GO TO 108 -- 107 CALL DPASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) -- 108 NA = 1-NA -- GO TO 115 -- 109 IF (IP .NE. 5) GO TO 112 -- IX2 = IW+IDOT -- IX3 = IX2+IDOT -- IX4 = IX3+IDOT -- IF (NA .NE. 0) GO TO 110 -- CALL DPASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- GO TO 111 -- 110 CALL DPASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- 111 NA = 1-NA -- GO TO 115 -- 112 IF (NA .NE. 0) GO TO 113 -- CALL DPASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) -- GO TO 114 -- 113 CALL DPASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) -- 114 IF (NAC .NE. 0) NA = 1-NA -- 115 L1 = L2 -- IW = IW+(IP-1)*IDOT -- 116 CONTINUE -- IF (NA .EQ. 0) RETURN -- N2 = N+N -- DO 117 I=1,N2 -- C(I) = CH(I) -- 117 CONTINUE -- RETURN -- END -- -- SUBROUTINE ZFFTB (N,C,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION C(*) ,WSAVE(*) -- IF (N .EQ. 1) RETURN -- IW1 = N+N+1 -- IW2 = IW1+N+N -- CALL ZFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) -- RETURN -- END -- -- SUBROUTINE ZFFTF1 (N,C,CH,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) -- NF = IFAC(2) -- NA = 0 -- L1 = 1 -- IW = 1 -- DO 116 K1=1,NF -- IP = IFAC(K1+2) -- L2 = IP*L1 -- IDO = N/L2 -- IDOT = IDO+IDO -- IDL1 = IDOT*L1 -- IF (IP .NE. 4) GO TO 103 -- IX2 = IW+IDOT -- IX3 = IX2+IDOT -- IF (NA .NE. 0) GO TO 101 -- CALL DPASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) -- GO TO 102 -- 101 CALL DPASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) -- 102 NA = 1-NA -- GO TO 115 -- 103 IF (IP .NE. 2) GO TO 106 -- IF (NA .NE. 0) GO TO 104 -- CALL DPASSF2 (IDOT,L1,C,CH,WA(IW)) -- GO TO 105 -- 104 CALL DPASSF2 (IDOT,L1,CH,C,WA(IW)) -- 105 NA = 1-NA -- GO TO 115 -- 106 IF (IP .NE. 3) GO TO 109 -- IX2 = IW+IDOT -- IF (NA .NE. 0) GO TO 107 -- CALL DPASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) -- GO TO 108 -- 107 CALL DPASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) -- 108 NA = 1-NA -- GO TO 115 -- 109 IF (IP .NE. 5) GO TO 112 -- IX2 = IW+IDOT -- IX3 = IX2+IDOT -- IX4 = IX3+IDOT -- IF (NA .NE. 0) GO TO 110 -- CALL DPASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- GO TO 111 -- 110 CALL DPASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- 111 NA = 1-NA -- GO TO 115 -- 112 IF (NA .NE. 0) GO TO 113 -- CALL DPASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) -- GO TO 114 -- 113 CALL DPASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) -- 114 IF (NAC .NE. 0) NA = 1-NA -- 115 L1 = L2 -- IW = IW+(IP-1)*IDOT -- 116 CONTINUE -- IF (NA .EQ. 0) RETURN -- N2 = N+N -- DO 117 I=1,N2 -- C(I) = CH(I) -- 117 CONTINUE -- RETURN -- END -- -- -- SUBROUTINE ZFFTF (N,C,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION C(*) ,WSAVE(*) -- IF (N .EQ. 1) RETURN -- IW1 = N+N+1 -- IW2 = IW1+N+N -- CALL ZFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) -- RETURN -- END -- -- -- SUBROUTINE ZFFTI1 (N,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) -- DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ -- NL = N -- NF = 0 -- J = 0 -- 101 J = J+1 -- IF (J-4) 102,102,103 -- 102 NTRY = NTRYH(J) -- GO TO 104 -- 103 NTRY = NTRY+2 -- 104 NQ = NL/NTRY -- NR = NL-NTRY*NQ -- IF (NR) 101,105,101 -- 105 NF = NF+1 -- IFAC(NF+2) = NTRY -- NL = NQ -- IF (NTRY .NE. 2) GO TO 107 -- IF (NF .EQ. 1) GO TO 107 -- DO 106 I=2,NF -- IB = NF-I+2 -- IFAC(IB+2) = IFAC(IB+1) -- 106 CONTINUE -- IFAC(3) = 2 -- 107 IF (NL .NE. 1) GO TO 104 -- IFAC(1) = N -- IFAC(2) = NF -- TPI = 6.2831853071795864769252867665590057D0 -- ARGH = TPI/DBLE(N) -- I = 2 -- L1 = 1 -- DO 110 K1=1,NF -- IP = IFAC(K1+2) -- LD = 0 -- L2 = L1*IP -- IDO = N/L2 -- IDOT = IDO+IDO+2 -- IPM = IP-1 -- DO 109 J=1,IPM -- I1 = I -- WA(I-1) = 1.0D0 -- WA(I) = 0.0D0 -- LD = LD+L1 -- FI = 0.0D0 -- ARGLD = DBLE(LD)*ARGH -- DO 108 II=4,IDOT,2 -- I = I+2 -- FI = FI+1.0D0 -- ARG = FI*ARGLD -- WA(I-1) = DCOS(ARG) -- WA(I) = DSIN(ARG) -- 108 CONTINUE -- IF (IP .LE. 5) GO TO 109 -- WA(I1-1) = WA(I-1) -- WA(I1) = WA(I) -- 109 CONTINUE -- L1 = L2 -- 110 CONTINUE -- RETURN -- END -- -- SUBROUTINE ZFFTI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- IF (N .EQ. 1) RETURN -- IW1 = N+N+1 -- IW2 = IW1+N+N -- CALL ZFFTI1 (N,WSAVE(IW1),WSAVE(IW2)) -- RETURN -- END -- -- SUBROUTINE DCOSQB1 (N,X,W,XH) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,W(*) ,XH(*) -- NS2 = (N+1)/2 -- NP2 = N+2 -- DO 101 I=3,N,2 -- XIM1 = X(I-1)+X(I) -- X(I) = X(I)-X(I-1) -- X(I-1) = XIM1 -- 101 CONTINUE -- X(1) = X(1)+X(1) -- MODN = MOD(N,2) -- IF (MODN .EQ. 0) X(N) = X(N)+X(N) -- CALL DFFTB (N,X,XH) -- DO 102 K=2,NS2 -- KC = NP2-K -- XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K) -- XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC) -- 102 CONTINUE -- IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1)) -- DO 103 K=2,NS2 -- KC = NP2-K -- X(K) = XH(K)+XH(KC) -- X(KC) = XH(K)-XH(KC) -- 103 CONTINUE -- X(1) = X(1)+X(1) -- RETURN -- END -- -- SUBROUTINE DCOSQF1 (N,X,W,XH) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,W(*) ,XH(*) -- NS2 = (N+1)/2 -- NP2 = N+2 -- DO 101 K=2,NS2 -- KC = NP2-K -- XH(K) = X(K)+X(KC) -- XH(KC) = X(K)-X(KC) -- 101 CONTINUE -- MODN = MOD(N,2) -- IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1) -- DO 102 K=2,NS2 -- KC = NP2-K -- X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K) -- X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC) -- 102 CONTINUE -- IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1) -- CALL DFFTF (N,X,XH) -- DO 103 I=3,N,2 -- XIM1 = X(I-1)-X(I) -- X(I) = X(I-1)+X(I) -- X(I-1) = XIM1 -- 103 CONTINUE -- RETURN -- END -- SUBROUTINE DCOSQI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- DATA PIH /1.5707963267948966192313216916397514D0/ -- DT = PIH/DBLE(N) -- FK = 0.0D0 -- DO 101 K=1,N -- FK = FK+1.0D0 -- WSAVE(K) = DCOS(FK*DT) -- 101 CONTINUE -- CALL DFFTI (N,WSAVE(N+1)) -- RETURN -- END -- SUBROUTINE DCOST (N,X,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,WSAVE(*) -- NM1 = N-1 -- NP1 = N+1 -- NS2 = N/2 -- IF (N-2) 106,101,102 -- 101 X1H = X(1)+X(2) -- X(2) = X(1)-X(2) -- X(1) = X1H -- RETURN -- 102 IF (N .GT. 3) GO TO 103 -- X1P3 = X(1)+X(3) -- TX2 = X(2)+X(2) -- X(2) = X(1)-X(3) -- X(1) = X1P3+TX2 -- X(3) = X1P3-TX2 -- RETURN -- 103 C1 = X(1)-X(N) -- X(1) = X(1)+X(N) -- DO 104 K=2,NS2 -- KC = NP1-K -- T1 = X(K)+X(KC) -- T2 = X(K)-X(KC) -- C1 = C1+WSAVE(KC)*T2 -- T2 = WSAVE(K)*T2 -- X(K) = T1-T2 -- X(KC) = T1+T2 -- 104 CONTINUE -- MODN = MOD(N,2) -- IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1) -- CALL DFFTF (NM1,X,WSAVE(N+1)) -- XIM2 = X(2) -- X(2) = C1 -- DO 105 I=4,N,2 -- XI = X(I) -- X(I) = X(I-2)-X(I-1) -- X(I-1) = XIM2 -- XIM2 = XI -- 105 CONTINUE -- IF (MODN .NE. 0) X(N) = XIM2 -- 106 RETURN -- END -- -- SUBROUTINE DZFFT1 (N,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) -- DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ -- 1 ,TPI/6.2831853071795864769252867665590057D0/ -- NL = N -- NF = 0 -- J = 0 -- 101 J = J+1 -- IF (J-4) 102,102,103 -- 102 NTRY = NTRYH(J) -- GO TO 104 -- 103 NTRY = NTRY+2 -- 104 NQ = NL/NTRY -- NR = NL-NTRY*NQ -- IF (NR) 101,105,101 -- 105 NF = NF+1 -- IFAC(NF+2) = NTRY -- NL = NQ -- IF (NTRY .NE. 2) GO TO 107 -- IF (NF .EQ. 1) GO TO 107 -- DO 106 I=2,NF -- IB = NF-I+2 -- IFAC(IB+2) = IFAC(IB+1) -- 106 CONTINUE -- IFAC(3) = 2 -- 107 IF (NL .NE. 1) GO TO 104 -- IFAC(1) = N -- IFAC(2) = NF -- ARGH = TPI/DBLE(N) -- IS = 0 -- NFM1 = NF-1 -- L1 = 1 -- IF (NFM1 .EQ. 0) RETURN -- DO 111 K1=1,NFM1 -- IP = IFAC(K1+2) -- L2 = L1*IP -- IDO = N/L2 -- IPM = IP-1 -- ARG1 = DBLE(L1)*ARGH -- CH1 = 1.0D0 -- SH1 = 0.0D0 -- DCH1 = DCOS(ARG1) -- DSH1 = DSIN(ARG1) -- DO 110 J=1,IPM -- CH1H = DCH1*CH1-DSH1*SH1 -- SH1 = DCH1*SH1+DSH1*CH1 -- CH1 = CH1H -- I = IS+2 -- WA(I-1) = CH1 -- WA(I) = SH1 -- IF (IDO .LT. 5) GO TO 109 -- DO 108 II=5,IDO,2 -- I = I+2 -- WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2) -- WA(I) = CH1*WA(I-2)+SH1*WA(I-3) -- 108 CONTINUE -- 109 IS = IS+IDO -- 110 CONTINUE -- L1 = L2 -- 111 CONTINUE -- RETURN -- END -- -- SUBROUTINE DCOSQB (N,X,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,WSAVE(*) -- DATA TSQRT2 /2.8284271247461900976033774484193961D0/ -- IF (N-2) 101,102,103 -- 101 X(1) = 4.0D0*X(1) -- RETURN -- 102 X1 = 4.0D0*(X(1)+X(2)) -- X(2) = TSQRT2*(X(1)-X(2)) -- X(1) = X1 -- RETURN -- 103 CALL DCOSQB1 (N,X,WSAVE,WSAVE(N+1)) -- RETURN -- END -- SUBROUTINE DCOSQF (N,X,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,WSAVE(*) -- DATA SQRT2 /1.4142135623730950488016887242096980D0/ -- IF (N-2) 102,101,103 -- 101 TSQX = SQRT2*X(2) -- X(2) = X(1)-TSQX -- X(1) = X(1)+TSQX -- 102 RETURN -- 103 CALL DCOSQF1 (N,X,WSAVE,WSAVE(N+1)) -- RETURN -- END -- SUBROUTINE DCOSTI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- DATA PI /3.1415926535897932384626433832795028D0/ -- IF (N .LE. 3) RETURN -- NM1 = N-1 -- NP1 = N+1 -- NS2 = N/2 -- DT = PI/DBLE(NM1) -- FK = 0.0D0 -- DO 101 K=2,NS2 -- KC = NP1-K -- FK = FK+1.0D0 -- WSAVE(K) = 2.0D0*DSIN(FK*DT) -- WSAVE(KC) = 2.0D0*DCOS(FK*DT) -- 101 CONTINUE -- CALL DFFTI (NM1,WSAVE(N+1)) -- RETURN -- END -- -- SUBROUTINE DZFFTB (N,R,AZERO,A,B,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION R(*) ,A(*) ,B(*) ,WSAVE(*) -- IF (N-2) 101,102,103 -- 101 R(1) = AZERO -- RETURN -- 102 R(1) = AZERO+A(1) -- R(2) = AZERO-A(1) -- RETURN -- 103 NS2 = (N-1)/2 -- DO 104 I=1,NS2 -- R(2*I) = .5D0*A(I) -- R(2*I+1) = -.5D0*B(I) -- 104 CONTINUE -- R(1) = AZERO -- IF (MOD(N,2) .EQ. 0) R(N) = A(NS2+1) -- CALL DFFTB (N,R,WSAVE(N+1)) -- RETURN -- END -- SUBROUTINE DZFFTF (N,R,AZERO,A,B,WSAVE) --C --C VERSION 3 JUNE 1979 --C -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION R(*) ,A(*) ,B(*) ,WSAVE(*) -- IF (N-2) 101,102,103 -- 101 AZERO = R(1) -- RETURN -- 102 AZERO = .5D0*(R(1)+R(2)) -- A(1) = .5D0*(R(1)-R(2)) -- RETURN -- 103 DO 104 I=1,N -- WSAVE(I) = R(I) -- 104 CONTINUE -- CALL DFFTF (N,WSAVE,WSAVE(N+1)) -- CF = 2.0D0/DBLE(N) -- CFM = -CF -- AZERO = .5D0*CF*WSAVE(1) -- NS2 = (N+1)/2 -- NS2M = NS2-1 -- DO 105 I=1,NS2M -- A(I) = CF*WSAVE(2*I) -- B(I) = CFM*WSAVE(2*I+1) -- 105 CONTINUE -- IF (MOD(N,2) .EQ. 1) RETURN -- A(NS2) = .5D0*CF*WSAVE(N) -- B(NS2) = 0.0D0 -- RETURN -- END -- SUBROUTINE DZFFTI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- IF (N .EQ. 1) RETURN -- CALL DZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1)) -- RETURN -- END -- SUBROUTINE DPASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , -- 1 C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), -- 2 CH2(IDL1,IP) -- IDOT = IDO/2 -- NT = IP*IDL1 -- IPP2 = IP+2 -- IPPH = (IP+1)/2 -- IDP = IP*IDO --C -- IF (IDO .LT. L1) GO TO 106 -- DO 103 J=2,IPPH -- JC = IPP2-J -- DO 102 K=1,L1 -- DO 101 I=1,IDO -- CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) -- CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) -- 101 CONTINUE -- 102 CONTINUE -- 103 CONTINUE -- DO 105 K=1,L1 -- DO 104 I=1,IDO -- CH(I,K,1) = CC(I,1,K) -- 104 CONTINUE -- 105 CONTINUE -- GO TO 112 -- 106 DO 109 J=2,IPPH -- JC = IPP2-J -- DO 108 I=1,IDO -- DO 107 K=1,L1 -- CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) -- CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) -- 107 CONTINUE -- 108 CONTINUE -- 109 CONTINUE -- DO 111 I=1,IDO -- DO 110 K=1,L1 -- CH(I,K,1) = CC(I,1,K) -- 110 CONTINUE -- 111 CONTINUE -- 112 IDL = 2-IDO -- INC = 0 -- DO 116 L=2,IPPH -- LC = IPP2-L -- IDL = IDL+IDO -- DO 113 IK=1,IDL1 -- C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) -- C2(IK,LC) = WA(IDL)*CH2(IK,IP) -- 113 CONTINUE -- IDLJ = IDL -- INC = INC+IDO -- DO 115 J=3,IPPH -- JC = IPP2-J -- IDLJ = IDLJ+INC -- IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP -- WAR = WA(IDLJ-1) -- WAI = WA(IDLJ) -- DO 114 IK=1,IDL1 -- C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) -- C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) -- 114 CONTINUE -- 115 CONTINUE -- 116 CONTINUE -- DO 118 J=2,IPPH -- DO 117 IK=1,IDL1 -- CH2(IK,1) = CH2(IK,1)+CH2(IK,J) -- 117 CONTINUE -- 118 CONTINUE -- DO 120 J=2,IPPH -- JC = IPP2-J -- DO 119 IK=2,IDL1,2 -- CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) -- CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) -- CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) -- CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) -- 119 CONTINUE -- 120 CONTINUE -- NAC = 1 -- IF (IDO .EQ. 2) RETURN -- NAC = 0 -- DO 121 IK=1,IDL1 -- C2(IK,1) = CH2(IK,1) -- 121 CONTINUE -- DO 123 J=2,IP -- DO 122 K=1,L1 -- C1(1,K,J) = CH(1,K,J) -- C1(2,K,J) = CH(2,K,J) -- 122 CONTINUE -- 123 CONTINUE -- IF (IDOT .GT. L1) GO TO 127 -- IDIJ = 0 -- DO 126 J=2,IP -- IDIJ = IDIJ+2 -- DO 125 I=4,IDO,2 -- IDIJ = IDIJ+2 -- DO 124 K=1,L1 -- C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) -- C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) -- 124 CONTINUE -- 125 CONTINUE -- 126 CONTINUE -- RETURN -- 127 IDJ = 2-IDO -- DO 130 J=2,IP -- IDJ = IDJ+IDO -- DO 129 K=1,L1 -- IDIJ = IDJ -- DO 128 I=4,IDO,2 -- IDIJ = IDIJ+2 -- C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) -- C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) -- 128 CONTINUE -- 129 CONTINUE -- 130 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSB2 (IDO,L1,CC,CH,WA1) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , -- 1 WA1(*) -- IF (IDO .GT. 2) GO TO 102 -- DO 101 K=1,L1 -- CH(1,K,1) = CC(1,1,K)+CC(1,2,K) -- CH(1,K,2) = CC(1,1,K)-CC(1,2,K) -- CH(2,K,1) = CC(2,1,K)+CC(2,2,K) -- CH(2,K,2) = CC(2,1,K)-CC(2,2,K) -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) -- TR2 = CC(I-1,1,K)-CC(I-1,2,K) -- CH(I,K,1) = CC(I,1,K)+CC(I,2,K) -- TI2 = CC(I,1,K)-CC(I,2,K) -- CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 -- CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSB3 (IDO,L1,CC,CH,WA1,WA2) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , -- 1 WA1(*) ,WA2(*) -- DATA TAUR,TAUI /-.5D0,.86602540378443864676372317075293618D0/ -- IF (IDO .NE. 2) GO TO 102 -- DO 101 K=1,L1 -- TR2 = CC(1,2,K)+CC(1,3,K) -- CR2 = CC(1,1,K)+TAUR*TR2 -- CH(1,K,1) = CC(1,1,K)+TR2 -- TI2 = CC(2,2,K)+CC(2,3,K) -- CI2 = CC(2,1,K)+TAUR*TI2 -- CH(2,K,1) = CC(2,1,K)+TI2 -- CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) -- CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) -- CH(1,K,2) = CR2-CI3 -- CH(1,K,3) = CR2+CI3 -- CH(2,K,2) = CI2+CR3 -- CH(2,K,3) = CI2-CR3 -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- TR2 = CC(I-1,2,K)+CC(I-1,3,K) -- CR2 = CC(I-1,1,K)+TAUR*TR2 -- CH(I-1,K,1) = CC(I-1,1,K)+TR2 -- TI2 = CC(I,2,K)+CC(I,3,K) -- CI2 = CC(I,1,K)+TAUR*TI2 -- CH(I,K,1) = CC(I,1,K)+TI2 -- CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) -- CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) -- DR2 = CR2-CI3 -- DR3 = CR2+CI3 -- DI2 = CI2+CR3 -- DI3 = CI2-CR3 -- CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 -- CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 -- CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 -- CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , -- 1 WA1(*) ,WA2(*) ,WA3(*) -- IF (IDO .NE. 2) GO TO 102 -- DO 101 K=1,L1 -- TI1 = CC(2,1,K)-CC(2,3,K) -- TI2 = CC(2,1,K)+CC(2,3,K) -- TR4 = CC(2,4,K)-CC(2,2,K) -- TI3 = CC(2,2,K)+CC(2,4,K) -- TR1 = CC(1,1,K)-CC(1,3,K) -- TR2 = CC(1,1,K)+CC(1,3,K) -- TI4 = CC(1,2,K)-CC(1,4,K) -- TR3 = CC(1,2,K)+CC(1,4,K) -- CH(1,K,1) = TR2+TR3 -- CH(1,K,3) = TR2-TR3 -- CH(2,K,1) = TI2+TI3 -- CH(2,K,3) = TI2-TI3 -- CH(1,K,2) = TR1+TR4 -- CH(1,K,4) = TR1-TR4 -- CH(2,K,2) = TI1+TI4 -- CH(2,K,4) = TI1-TI4 -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- TI1 = CC(I,1,K)-CC(I,3,K) -- TI2 = CC(I,1,K)+CC(I,3,K) -- TI3 = CC(I,2,K)+CC(I,4,K) -- TR4 = CC(I,4,K)-CC(I,2,K) -- TR1 = CC(I-1,1,K)-CC(I-1,3,K) -- TR2 = CC(I-1,1,K)+CC(I-1,3,K) -- TI4 = CC(I-1,2,K)-CC(I-1,4,K) -- TR3 = CC(I-1,2,K)+CC(I-1,4,K) -- CH(I-1,K,1) = TR2+TR3 -- CR3 = TR2-TR3 -- CH(I,K,1) = TI2+TI3 -- CI3 = TI2-TI3 -- CR2 = TR1+TR4 -- CR4 = TR1-TR4 -- CI2 = TI1+TI4 -- CI4 = TI1-TI4 -- CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 -- CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 -- CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 -- CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 -- CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 -- CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , -- 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) -- DATA TR11,TI11,TR12,TI12 / -- 1 .30901699437494742410229341718281905D0, -- 2 .95105651629515357211643933337938214D0, -- 3 -.80901699437494742410229341718281906D0, -- 4 .58778525229247312916870595463907276D0/ -- IF (IDO .NE. 2) GO TO 102 -- DO 101 K=1,L1 -- TI5 = CC(2,2,K)-CC(2,5,K) -- TI2 = CC(2,2,K)+CC(2,5,K) -- TI4 = CC(2,3,K)-CC(2,4,K) -- TI3 = CC(2,3,K)+CC(2,4,K) -- TR5 = CC(1,2,K)-CC(1,5,K) -- TR2 = CC(1,2,K)+CC(1,5,K) -- TR4 = CC(1,3,K)-CC(1,4,K) -- TR3 = CC(1,3,K)+CC(1,4,K) -- CH(1,K,1) = CC(1,1,K)+TR2+TR3 -- CH(2,K,1) = CC(2,1,K)+TI2+TI3 -- CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 -- CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 -- CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 -- CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 -- CR5 = TI11*TR5+TI12*TR4 -- CI5 = TI11*TI5+TI12*TI4 -- CR4 = TI12*TR5-TI11*TR4 -- CI4 = TI12*TI5-TI11*TI4 -- CH(1,K,2) = CR2-CI5 -- CH(1,K,5) = CR2+CI5 -- CH(2,K,2) = CI2+CR5 -- CH(2,K,3) = CI3+CR4 -- CH(1,K,3) = CR3-CI4 -- CH(1,K,4) = CR3+CI4 -- CH(2,K,4) = CI3-CR4 -- CH(2,K,5) = CI2-CR5 -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- TI5 = CC(I,2,K)-CC(I,5,K) -- TI2 = CC(I,2,K)+CC(I,5,K) -- TI4 = CC(I,3,K)-CC(I,4,K) -- TI3 = CC(I,3,K)+CC(I,4,K) -- TR5 = CC(I-1,2,K)-CC(I-1,5,K) -- TR2 = CC(I-1,2,K)+CC(I-1,5,K) -- TR4 = CC(I-1,3,K)-CC(I-1,4,K) -- TR3 = CC(I-1,3,K)+CC(I-1,4,K) -- CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 -- CH(I,K,1) = CC(I,1,K)+TI2+TI3 -- CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 -- CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 -- CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 -- CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 -- CR5 = TI11*TR5+TI12*TR4 -- CI5 = TI11*TI5+TI12*TI4 -- CR4 = TI12*TR5-TI11*TR4 -- CI4 = TI12*TI5-TI11*TI4 -- DR3 = CR3-CI4 -- DR4 = CR3+CI4 -- DI3 = CI3+CR4 -- DI4 = CI3-CR4 -- DR5 = CR2+CI5 -- DR2 = CR2-CI5 -- DI5 = CI2-CR5 -- DI2 = CI2+CR5 -- CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 -- CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 -- CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 -- CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 -- CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 -- CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 -- CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 -- CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , -- 1 C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), -- 2 CH2(IDL1,IP) -- IDOT = IDO/2 -- NT = IP*IDL1 -- IPP2 = IP+2 -- IPPH = (IP+1)/2 -- IDP = IP*IDO --C -- IF (IDO .LT. L1) GO TO 106 -- DO 103 J=2,IPPH -- JC = IPP2-J -- DO 102 K=1,L1 -- DO 101 I=1,IDO -- CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) -- CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) -- 101 CONTINUE -- 102 CONTINUE -- 103 CONTINUE -- DO 105 K=1,L1 -- DO 104 I=1,IDO -- CH(I,K,1) = CC(I,1,K) -- 104 CONTINUE -- 105 CONTINUE -- GO TO 112 -- 106 DO 109 J=2,IPPH -- JC = IPP2-J -- DO 108 I=1,IDO -- DO 107 K=1,L1 -- CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) -- CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) -- 107 CONTINUE -- 108 CONTINUE -- 109 CONTINUE -- DO 111 I=1,IDO -- DO 110 K=1,L1 -- CH(I,K,1) = CC(I,1,K) -- 110 CONTINUE -- 111 CONTINUE -- 112 IDL = 2-IDO -- INC = 0 -- DO 116 L=2,IPPH -- LC = IPP2-L -- IDL = IDL+IDO -- DO 113 IK=1,IDL1 -- C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) -- C2(IK,LC) = -WA(IDL)*CH2(IK,IP) -- 113 CONTINUE -- IDLJ = IDL -- INC = INC+IDO -- DO 115 J=3,IPPH -- JC = IPP2-J -- IDLJ = IDLJ+INC -- IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP -- WAR = WA(IDLJ-1) -- WAI = WA(IDLJ) -- DO 114 IK=1,IDL1 -- C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) -- C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) -- 114 CONTINUE -- 115 CONTINUE -- 116 CONTINUE -- DO 118 J=2,IPPH -- DO 117 IK=1,IDL1 -- CH2(IK,1) = CH2(IK,1)+CH2(IK,J) -- 117 CONTINUE -- 118 CONTINUE -- DO 120 J=2,IPPH -- JC = IPP2-J -- DO 119 IK=2,IDL1,2 -- CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) -- CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) -- CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) -- CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) -- 119 CONTINUE -- 120 CONTINUE -- NAC = 1 -- IF (IDO .EQ. 2) RETURN -- NAC = 0 -- DO 121 IK=1,IDL1 -- C2(IK,1) = CH2(IK,1) -- 121 CONTINUE -- DO 123 J=2,IP -- DO 122 K=1,L1 -- C1(1,K,J) = CH(1,K,J) -- C1(2,K,J) = CH(2,K,J) -- 122 CONTINUE -- 123 CONTINUE -- IF (IDOT .GT. L1) GO TO 127 -- IDIJ = 0 -- DO 126 J=2,IP -- IDIJ = IDIJ+2 -- DO 125 I=4,IDO,2 -- IDIJ = IDIJ+2 -- DO 124 K=1,L1 -- C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) -- C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) -- 124 CONTINUE -- 125 CONTINUE -- 126 CONTINUE -- RETURN -- 127 IDJ = 2-IDO -- DO 130 J=2,IP -- IDJ = IDJ+IDO -- DO 129 K=1,L1 -- IDIJ = IDJ -- DO 128 I=4,IDO,2 -- IDIJ = IDIJ+2 -- C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) -- C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) -- 128 CONTINUE -- 129 CONTINUE -- 130 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSF2 (IDO,L1,CC,CH,WA1) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , -- 1 WA1(*) -- IF (IDO .GT. 2) GO TO 102 -- DO 101 K=1,L1 -- CH(1,K,1) = CC(1,1,K)+CC(1,2,K) -- CH(1,K,2) = CC(1,1,K)-CC(1,2,K) -- CH(2,K,1) = CC(2,1,K)+CC(2,2,K) -- CH(2,K,2) = CC(2,1,K)-CC(2,2,K) -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) -- TR2 = CC(I-1,1,K)-CC(I-1,2,K) -- CH(I,K,1) = CC(I,1,K)+CC(I,2,K) -- TI2 = CC(I,1,K)-CC(I,2,K) -- CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 -- CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSF3 (IDO,L1,CC,CH,WA1,WA2) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , -- 1 WA1(*) ,WA2(*) -- DATA TAUR,TAUI /-.5D0,-.86602540378443864676372317075293618D0/ -- IF (IDO .NE. 2) GO TO 102 -- DO 101 K=1,L1 -- TR2 = CC(1,2,K)+CC(1,3,K) -- CR2 = CC(1,1,K)+TAUR*TR2 -- CH(1,K,1) = CC(1,1,K)+TR2 -- TI2 = CC(2,2,K)+CC(2,3,K) -- CI2 = CC(2,1,K)+TAUR*TI2 -- CH(2,K,1) = CC(2,1,K)+TI2 -- CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) -- CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) -- CH(1,K,2) = CR2-CI3 -- CH(1,K,3) = CR2+CI3 -- CH(2,K,2) = CI2+CR3 -- CH(2,K,3) = CI2-CR3 -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- TR2 = CC(I-1,2,K)+CC(I-1,3,K) -- CR2 = CC(I-1,1,K)+TAUR*TR2 -- CH(I-1,K,1) = CC(I-1,1,K)+TR2 -- TI2 = CC(I,2,K)+CC(I,3,K) -- CI2 = CC(I,1,K)+TAUR*TI2 -- CH(I,K,1) = CC(I,1,K)+TI2 -- CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) -- CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) -- DR2 = CR2-CI3 -- DR3 = CR2+CI3 -- DI2 = CI2+CR3 -- DI3 = CI2-CR3 -- CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 -- CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 -- CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 -- CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , -- 1 WA1(*) ,WA2(*) ,WA3(*) -- IF (IDO .NE. 2) GO TO 102 -- DO 101 K=1,L1 -- TI1 = CC(2,1,K)-CC(2,3,K) -- TI2 = CC(2,1,K)+CC(2,3,K) -- TR4 = CC(2,2,K)-CC(2,4,K) -- TI3 = CC(2,2,K)+CC(2,4,K) -- TR1 = CC(1,1,K)-CC(1,3,K) -- TR2 = CC(1,1,K)+CC(1,3,K) -- TI4 = CC(1,4,K)-CC(1,2,K) -- TR3 = CC(1,2,K)+CC(1,4,K) -- CH(1,K,1) = TR2+TR3 -- CH(1,K,3) = TR2-TR3 -- CH(2,K,1) = TI2+TI3 -- CH(2,K,3) = TI2-TI3 -- CH(1,K,2) = TR1+TR4 -- CH(1,K,4) = TR1-TR4 -- CH(2,K,2) = TI1+TI4 -- CH(2,K,4) = TI1-TI4 -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- TI1 = CC(I,1,K)-CC(I,3,K) -- TI2 = CC(I,1,K)+CC(I,3,K) -- TI3 = CC(I,2,K)+CC(I,4,K) -- TR4 = CC(I,2,K)-CC(I,4,K) -- TR1 = CC(I-1,1,K)-CC(I-1,3,K) -- TR2 = CC(I-1,1,K)+CC(I-1,3,K) -- TI4 = CC(I-1,4,K)-CC(I-1,2,K) -- TR3 = CC(I-1,2,K)+CC(I-1,4,K) -- CH(I-1,K,1) = TR2+TR3 -- CR3 = TR2-TR3 -- CH(I,K,1) = TI2+TI3 -- CI3 = TI2-TI3 -- CR2 = TR1+TR4 -- CR4 = TR1-TR4 -- CI2 = TI1+TI4 -- CI4 = TI1-TI4 -- CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 -- CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 -- CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 -- CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 -- CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 -- CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DPASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , -- 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) -- DATA TR11,TI11,TR12,TI12 / -- 1 .30901699437494742410229341718281905D0, -- 2 -.95105651629515357211643933337938214D0, -- 3 -.80901699437494742410229341718281906D0, -- 4 -.58778525229247312916870595463907276D0/ -- IF (IDO .NE. 2) GO TO 102 -- DO 101 K=1,L1 -- TI5 = CC(2,2,K)-CC(2,5,K) -- TI2 = CC(2,2,K)+CC(2,5,K) -- TI4 = CC(2,3,K)-CC(2,4,K) -- TI3 = CC(2,3,K)+CC(2,4,K) -- TR5 = CC(1,2,K)-CC(1,5,K) -- TR2 = CC(1,2,K)+CC(1,5,K) -- TR4 = CC(1,3,K)-CC(1,4,K) -- TR3 = CC(1,3,K)+CC(1,4,K) -- CH(1,K,1) = CC(1,1,K)+TR2+TR3 -- CH(2,K,1) = CC(2,1,K)+TI2+TI3 -- CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 -- CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 -- CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 -- CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 -- CR5 = TI11*TR5+TI12*TR4 -- CI5 = TI11*TI5+TI12*TI4 -- CR4 = TI12*TR5-TI11*TR4 -- CI4 = TI12*TI5-TI11*TI4 -- CH(1,K,2) = CR2-CI5 -- CH(1,K,5) = CR2+CI5 -- CH(2,K,2) = CI2+CR5 -- CH(2,K,3) = CI3+CR4 -- CH(1,K,3) = CR3-CI4 -- CH(1,K,4) = CR3+CI4 -- CH(2,K,4) = CI3-CR4 -- CH(2,K,5) = CI2-CR5 -- 101 CONTINUE -- RETURN -- 102 DO 104 K=1,L1 -- DO 103 I=2,IDO,2 -- TI5 = CC(I,2,K)-CC(I,5,K) -- TI2 = CC(I,2,K)+CC(I,5,K) -- TI4 = CC(I,3,K)-CC(I,4,K) -- TI3 = CC(I,3,K)+CC(I,4,K) -- TR5 = CC(I-1,2,K)-CC(I-1,5,K) -- TR2 = CC(I-1,2,K)+CC(I-1,5,K) -- TR4 = CC(I-1,3,K)-CC(I-1,4,K) -- TR3 = CC(I-1,3,K)+CC(I-1,4,K) -- CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 -- CH(I,K,1) = CC(I,1,K)+TI2+TI3 -- CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 -- CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 -- CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 -- CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 -- CR5 = TI11*TR5+TI12*TR4 -- CI5 = TI11*TI5+TI12*TI4 -- CR4 = TI12*TR5-TI11*TR4 -- CI4 = TI12*TI5-TI11*TI4 -- DR3 = CR3-CI4 -- DR4 = CR3+CI4 -- DI3 = CI3+CR4 -- DI4 = CI3-CR4 -- DR5 = CR2+CI5 -- DR2 = CR2-CI5 -- DI5 = CI2-CR5 -- DI2 = CI2+CR5 -- CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 -- CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 -- CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 -- CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 -- CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 -- CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 -- CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 -- CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 -- 103 CONTINUE -- 104 CONTINUE -- RETURN -- END -- SUBROUTINE DRADB2 (IDO,L1,CC,CH,WA1) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , -- 1 WA1(*) -- DO 101 K=1,L1 -- CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) -- CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) -- 101 CONTINUE -- IF (IDO-2) 107,105,102 -- 102 IDP2 = IDO+2 -- DO 104 K=1,L1 -- DO 103 I=3,IDO,2 -- IC = IDP2-I -- CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) -- TR2 = CC(I-1,1,K)-CC(IC-1,2,K) -- CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) -- TI2 = CC(I,1,K)+CC(IC,2,K) -- CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 -- CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 -- 103 CONTINUE -- 104 CONTINUE -- IF (MOD(IDO,2) .EQ. 1) RETURN -- 105 DO 106 K=1,L1 -- CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) -- CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) -- 106 CONTINUE -- 107 RETURN -- END -- SUBROUTINE DRADB3 (IDO,L1,CC,CH,WA1,WA2) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , -- 1 WA1(*) ,WA2(*) -- DATA TAUR,TAUI /-.5D0,.86602540378443864676372317075293618D0/ -- DO 101 K=1,L1 -- TR2 = CC(IDO,2,K)+CC(IDO,2,K) -- CR2 = CC(1,1,K)+TAUR*TR2 -- CH(1,K,1) = CC(1,1,K)+TR2 -- CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) -- CH(1,K,2) = CR2-CI3 -- CH(1,K,3) = CR2+CI3 -- 101 CONTINUE -- IF (IDO .EQ. 1) RETURN -- IDP2 = IDO+2 -- DO 103 K=1,L1 -- DO 102 I=3,IDO,2 -- IC = IDP2-I -- TR2 = CC(I-1,3,K)+CC(IC-1,2,K) -- CR2 = CC(I-1,1,K)+TAUR*TR2 -- CH(I-1,K,1) = CC(I-1,1,K)+TR2 -- TI2 = CC(I,3,K)-CC(IC,2,K) -- CI2 = CC(I,1,K)+TAUR*TI2 -- CH(I,K,1) = CC(I,1,K)+TI2 -- CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) -- CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) -- DR2 = CR2-CI3 -- DR3 = CR2+CI3 -- DI2 = CI2+CR3 -- DI3 = CI2-CR3 -- CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 -- CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 -- CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 -- CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 -- 102 CONTINUE -- 103 CONTINUE -- RETURN -- END -- SUBROUTINE DRADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , -- 1 WA1(*) ,WA2(*) ,WA3(*) -- DATA SQRT2 /1.4142135623730950488016887242096980D0/ -- DO 101 K=1,L1 -- TR1 = CC(1,1,K)-CC(IDO,4,K) -- TR2 = CC(1,1,K)+CC(IDO,4,K) -- TR3 = CC(IDO,2,K)+CC(IDO,2,K) -- TR4 = CC(1,3,K)+CC(1,3,K) -- CH(1,K,1) = TR2+TR3 -- CH(1,K,2) = TR1-TR4 -- CH(1,K,3) = TR2-TR3 -- CH(1,K,4) = TR1+TR4 -- 101 CONTINUE -- IF (IDO-2) 107,105,102 -- 102 IDP2 = IDO+2 -- DO 104 K=1,L1 -- DO 103 I=3,IDO,2 -- IC = IDP2-I -- TI1 = CC(I,1,K)+CC(IC,4,K) -- TI2 = CC(I,1,K)-CC(IC,4,K) -- TI3 = CC(I,3,K)-CC(IC,2,K) -- TR4 = CC(I,3,K)+CC(IC,2,K) -- TR1 = CC(I-1,1,K)-CC(IC-1,4,K) -- TR2 = CC(I-1,1,K)+CC(IC-1,4,K) -- TI4 = CC(I-1,3,K)-CC(IC-1,2,K) -- TR3 = CC(I-1,3,K)+CC(IC-1,2,K) -- CH(I-1,K,1) = TR2+TR3 -- CR3 = TR2-TR3 -- CH(I,K,1) = TI2+TI3 -- CI3 = TI2-TI3 -- CR2 = TR1-TR4 -- CR4 = TR1+TR4 -- CI2 = TI1+TI4 -- CI4 = TI1-TI4 -- CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 -- CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 -- CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 -- CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 -- CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 -- CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 -- 103 CONTINUE -- 104 CONTINUE -- IF (MOD(IDO,2) .EQ. 1) RETURN -- 105 CONTINUE -- DO 106 K=1,L1 -- TI1 = CC(1,2,K)+CC(1,4,K) -- TI2 = CC(1,4,K)-CC(1,2,K) -- TR1 = CC(IDO,1,K)-CC(IDO,3,K) -- TR2 = CC(IDO,1,K)+CC(IDO,3,K) -- CH(IDO,K,1) = TR2+TR2 -- CH(IDO,K,2) = SQRT2*(TR1-TI1) -- CH(IDO,K,3) = TI2+TI2 -- CH(IDO,K,4) = -SQRT2*(TR1+TI1) -- 106 CONTINUE -- 107 RETURN -- END -- SUBROUTINE DRADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , -- 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) -- DATA TR11,TI11,TR12,TI12 / -- 1 .30901699437494742410229341718281905D0, -- 2 .95105651629515357211643933337938214D0, -- 3 -.80901699437494742410229341718281906D0, -- 4 .58778525229247312916870595463907276D0/ -- DO 101 K=1,L1 -- TI5 = CC(1,3,K)+CC(1,3,K) -- TI4 = CC(1,5,K)+CC(1,5,K) -- TR2 = CC(IDO,2,K)+CC(IDO,2,K) -- TR3 = CC(IDO,4,K)+CC(IDO,4,K) -- CH(1,K,1) = CC(1,1,K)+TR2+TR3 -- CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 -- CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 -- CI5 = TI11*TI5+TI12*TI4 -- CI4 = TI12*TI5-TI11*TI4 -- CH(1,K,2) = CR2-CI5 -- CH(1,K,3) = CR3-CI4 -- CH(1,K,4) = CR3+CI4 -- CH(1,K,5) = CR2+CI5 -- 101 CONTINUE -- IF (IDO .EQ. 1) RETURN -- IDP2 = IDO+2 -- DO 103 K=1,L1 -- DO 102 I=3,IDO,2 -- IC = IDP2-I -- TI5 = CC(I,3,K)+CC(IC,2,K) -- TI2 = CC(I,3,K)-CC(IC,2,K) -- TI4 = CC(I,5,K)+CC(IC,4,K) -- TI3 = CC(I,5,K)-CC(IC,4,K) -- TR5 = CC(I-1,3,K)-CC(IC-1,2,K) -- TR2 = CC(I-1,3,K)+CC(IC-1,2,K) -- TR4 = CC(I-1,5,K)-CC(IC-1,4,K) -- TR3 = CC(I-1,5,K)+CC(IC-1,4,K) -- CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 -- CH(I,K,1) = CC(I,1,K)+TI2+TI3 -- CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 -- CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 -- CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 -- CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 -- CR5 = TI11*TR5+TI12*TR4 -- CI5 = TI11*TI5+TI12*TI4 -- CR4 = TI12*TR5-TI11*TR4 -- CI4 = TI12*TI5-TI11*TI4 -- DR3 = CR3-CI4 -- DR4 = CR3+CI4 -- DI3 = CI3+CR4 -- DI4 = CI3-CR4 -- DR5 = CR2+CI5 -- DR2 = CR2-CI5 -- DI5 = CI2-CR5 -- DI2 = CI2+CR5 -- CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 -- CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 -- CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 -- CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 -- CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 -- CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 -- CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 -- CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 -- 102 CONTINUE -- 103 CONTINUE -- RETURN -- END -- SUBROUTINE DRADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , -- 1 C1(IDO,L1,IP) ,C2(IDL1,IP), -- 2 CH2(IDL1,IP) ,WA(*) -- DATA TPI/6.2831853071795864769252867665590057D0/ -- ARG = TPI/DBLE(IP) -- DCP = DCOS(ARG) -- DSP = DSIN(ARG) -- IDP2 = IDO+2 -- NBD = (IDO-1)/2 -- IPP2 = IP+2 -- IPPH = (IP+1)/2 -- IF (IDO .LT. L1) GO TO 103 -- DO 102 K=1,L1 -- DO 101 I=1,IDO -- CH(I,K,1) = CC(I,1,K) -- 101 CONTINUE -- 102 CONTINUE -- GO TO 106 -- 103 DO 105 I=1,IDO -- DO 104 K=1,L1 -- CH(I,K,1) = CC(I,1,K) -- 104 CONTINUE -- 105 CONTINUE -- 106 DO 108 J=2,IPPH -- JC = IPP2-J -- J2 = J+J -- DO 107 K=1,L1 -- CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) -- CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) -- 107 CONTINUE -- 108 CONTINUE -- IF (IDO .EQ. 1) GO TO 116 -- IF (NBD .LT. L1) GO TO 112 -- DO 111 J=2,IPPH -- JC = IPP2-J -- DO 110 K=1,L1 -- DO 109 I=3,IDO,2 -- IC = IDP2-I -- CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) -- CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) -- CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) -- CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) -- 109 CONTINUE -- 110 CONTINUE -- 111 CONTINUE -- GO TO 116 -- 112 DO 115 J=2,IPPH -- JC = IPP2-J -- DO 114 I=3,IDO,2 -- IC = IDP2-I -- DO 113 K=1,L1 -- CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) -- CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) -- CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) -- CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) -- 113 CONTINUE -- 114 CONTINUE -- 115 CONTINUE -- 116 AR1 = 1.0D0 -- AI1 = 0.0D0 -- DO 120 L=2,IPPH -- LC = IPP2-L -- AR1H = DCP*AR1-DSP*AI1 -- AI1 = DCP*AI1+DSP*AR1 -- AR1 = AR1H -- DO 117 IK=1,IDL1 -- C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) -- C2(IK,LC) = AI1*CH2(IK,IP) -- 117 CONTINUE -- DC2 = AR1 -- DS2 = AI1 -- AR2 = AR1 -- AI2 = AI1 -- DO 119 J=3,IPPH -- JC = IPP2-J -- AR2H = DC2*AR2-DS2*AI2 -- AI2 = DC2*AI2+DS2*AR2 -- AR2 = AR2H -- DO 118 IK=1,IDL1 -- C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) -- C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) -- 118 CONTINUE -- 119 CONTINUE -- 120 CONTINUE -- DO 122 J=2,IPPH -- DO 121 IK=1,IDL1 -- CH2(IK,1) = CH2(IK,1)+CH2(IK,J) -- 121 CONTINUE -- 122 CONTINUE -- DO 124 J=2,IPPH -- JC = IPP2-J -- DO 123 K=1,L1 -- CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) -- CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) -- 123 CONTINUE -- 124 CONTINUE -- IF (IDO .EQ. 1) GO TO 132 -- IF (NBD .LT. L1) GO TO 128 -- DO 127 J=2,IPPH -- JC = IPP2-J -- DO 126 K=1,L1 -- DO 125 I=3,IDO,2 -- CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) -- CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) -- CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) -- CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) -- 125 CONTINUE -- 126 CONTINUE -- 127 CONTINUE -- GO TO 132 -- 128 DO 131 J=2,IPPH -- JC = IPP2-J -- DO 130 I=3,IDO,2 -- DO 129 K=1,L1 -- CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) -- CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) -- CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) -- CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) -- 129 CONTINUE -- 130 CONTINUE -- 131 CONTINUE -- 132 CONTINUE -- IF (IDO .EQ. 1) RETURN -- DO 133 IK=1,IDL1 -- C2(IK,1) = CH2(IK,1) -- 133 CONTINUE -- DO 135 J=2,IP -- DO 134 K=1,L1 -- C1(1,K,J) = CH(1,K,J) -- 134 CONTINUE -- 135 CONTINUE -- IF (NBD .GT. L1) GO TO 139 -- IS = -IDO -- DO 138 J=2,IP -- IS = IS+IDO -- IDIJ = IS -- DO 137 I=3,IDO,2 -- IDIJ = IDIJ+2 -- DO 136 K=1,L1 -- C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) -- C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) -- 136 CONTINUE -- 137 CONTINUE -- 138 CONTINUE -- GO TO 143 -- 139 IS = -IDO -- DO 142 J=2,IP -- IS = IS+IDO -- DO 141 K=1,L1 -- IDIJ = IS -- DO 140 I=3,IDO,2 -- IDIJ = IDIJ+2 -- C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) -- C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) -- 140 CONTINUE -- 141 CONTINUE -- 142 CONTINUE -- 143 RETURN -- END -- SUBROUTINE DRADF2 (IDO,L1,CC,CH,WA1) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , -- 1 WA1(*) -- DO 101 K=1,L1 -- CH(1,1,K) = CC(1,K,1)+CC(1,K,2) -- CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) -- 101 CONTINUE -- IF (IDO-2) 107,105,102 -- 102 IDP2 = IDO+2 -- DO 104 K=1,L1 -- DO 103 I=3,IDO,2 -- IC = IDP2-I -- TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) -- TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) -- CH(I,1,K) = CC(I,K,1)+TI2 -- CH(IC,2,K) = TI2-CC(I,K,1) -- CH(I-1,1,K) = CC(I-1,K,1)+TR2 -- CH(IC-1,2,K) = CC(I-1,K,1)-TR2 -- 103 CONTINUE -- 104 CONTINUE -- IF (MOD(IDO,2) .EQ. 1) RETURN -- 105 DO 106 K=1,L1 -- CH(1,2,K) = -CC(IDO,K,2) -- CH(IDO,1,K) = CC(IDO,K,1) -- 106 CONTINUE -- 107 RETURN -- END -- SUBROUTINE DRADF3 (IDO,L1,CC,CH,WA1,WA2) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , -- 1 WA1(*) ,WA2(*) -- DATA TAUR,TAUI /-.5D0,.86602540378443864676372317075293618D0/ -- DO 101 K=1,L1 -- CR2 = CC(1,K,2)+CC(1,K,3) -- CH(1,1,K) = CC(1,K,1)+CR2 -- CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) -- CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 -- 101 CONTINUE -- IF (IDO .EQ. 1) RETURN -- IDP2 = IDO+2 -- DO 103 K=1,L1 -- DO 102 I=3,IDO,2 -- IC = IDP2-I -- DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) -- DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) -- DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) -- DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) -- CR2 = DR2+DR3 -- CI2 = DI2+DI3 -- CH(I-1,1,K) = CC(I-1,K,1)+CR2 -- CH(I,1,K) = CC(I,K,1)+CI2 -- TR2 = CC(I-1,K,1)+TAUR*CR2 -- TI2 = CC(I,K,1)+TAUR*CI2 -- TR3 = TAUI*(DI2-DI3) -- TI3 = TAUI*(DR3-DR2) -- CH(I-1,3,K) = TR2+TR3 -- CH(IC-1,2,K) = TR2-TR3 -- CH(I,3,K) = TI2+TI3 -- CH(IC,2,K) = TI3-TI2 -- 102 CONTINUE -- 103 CONTINUE -- RETURN -- END -- SUBROUTINE DRADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , -- 1 WA1(*) ,WA2(*) ,WA3(*) -- DATA HSQT2 /0.70710678118654752440084436210484904D0/ -- DO 101 K=1,L1 -- TR1 = CC(1,K,2)+CC(1,K,4) -- TR2 = CC(1,K,1)+CC(1,K,3) -- CH(1,1,K) = TR1+TR2 -- CH(IDO,4,K) = TR2-TR1 -- CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) -- CH(1,3,K) = CC(1,K,4)-CC(1,K,2) -- 101 CONTINUE -- IF (IDO-2) 107,105,102 -- 102 IDP2 = IDO+2 -- DO 104 K=1,L1 -- DO 103 I=3,IDO,2 -- IC = IDP2-I -- CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) -- CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) -- CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) -- CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) -- CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) -- CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) -- TR1 = CR2+CR4 -- TR4 = CR4-CR2 -- TI1 = CI2+CI4 -- TI4 = CI2-CI4 -- TI2 = CC(I,K,1)+CI3 -- TI3 = CC(I,K,1)-CI3 -- TR2 = CC(I-1,K,1)+CR3 -- TR3 = CC(I-1,K,1)-CR3 -- CH(I-1,1,K) = TR1+TR2 -- CH(IC-1,4,K) = TR2-TR1 -- CH(I,1,K) = TI1+TI2 -- CH(IC,4,K) = TI1-TI2 -- CH(I-1,3,K) = TI4+TR3 -- CH(IC-1,2,K) = TR3-TI4 -- CH(I,3,K) = TR4+TI3 -- CH(IC,2,K) = TR4-TI3 -- 103 CONTINUE -- 104 CONTINUE -- IF (MOD(IDO,2) .EQ. 1) RETURN -- 105 CONTINUE -- DO 106 K=1,L1 -- TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) -- TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) -- CH(IDO,1,K) = TR1+CC(IDO,K,1) -- CH(IDO,3,K) = CC(IDO,K,1)-TR1 -- CH(1,2,K) = TI1-CC(IDO,K,3) -- CH(1,4,K) = TI1+CC(IDO,K,3) -- 106 CONTINUE -- 107 RETURN -- END -- SUBROUTINE DRADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , -- 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) -- DATA TR11,TI11,TR12,TI12 / -- 1 .30901699437494742410229341718281905D0, -- 2 .95105651629515357211643933337938214D0, -- 3 -.80901699437494742410229341718281906D0, -- 4 .58778525229247312916870595463907276D0/ -- DO 101 K=1,L1 -- CR2 = CC(1,K,5)+CC(1,K,2) -- CI5 = CC(1,K,5)-CC(1,K,2) -- CR3 = CC(1,K,4)+CC(1,K,3) -- CI4 = CC(1,K,4)-CC(1,K,3) -- CH(1,1,K) = CC(1,K,1)+CR2+CR3 -- CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 -- CH(1,3,K) = TI11*CI5+TI12*CI4 -- CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 -- CH(1,5,K) = TI12*CI5-TI11*CI4 -- 101 CONTINUE -- IF (IDO .EQ. 1) RETURN -- IDP2 = IDO+2 -- DO 103 K=1,L1 -- DO 102 I=3,IDO,2 -- IC = IDP2-I -- DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) -- DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) -- DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) -- DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) -- DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) -- DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) -- DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) -- DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) -- CR2 = DR2+DR5 -- CI5 = DR5-DR2 -- CR5 = DI2-DI5 -- CI2 = DI2+DI5 -- CR3 = DR3+DR4 -- CI4 = DR4-DR3 -- CR4 = DI3-DI4 -- CI3 = DI3+DI4 -- CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 -- CH(I,1,K) = CC(I,K,1)+CI2+CI3 -- TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 -- TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 -- TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 -- TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 -- TR5 = TI11*CR5+TI12*CR4 -- TI5 = TI11*CI5+TI12*CI4 -- TR4 = TI12*CR5-TI11*CR4 -- TI4 = TI12*CI5-TI11*CI4 -- CH(I-1,3,K) = TR2+TR5 -- CH(IC-1,2,K) = TR2-TR5 -- CH(I,3,K) = TI2+TI5 -- CH(IC,2,K) = TI5-TI2 -- CH(I-1,5,K) = TR3+TR4 -- CH(IC-1,4,K) = TR3-TR4 -- CH(I,5,K) = TI3+TI4 -- CH(IC,4,K) = TI4-TI3 -- 102 CONTINUE -- 103 CONTINUE -- RETURN -- END -- SUBROUTINE DRADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , -- 1 C1(IDO,L1,IP) ,C2(IDL1,IP), -- 2 CH2(IDL1,IP) ,WA(*) -- DATA TPI/6.2831853071795864769252867665590057D0/ -- ARG = TPI/DBLE(IP) -- DCP = DCOS(ARG) -- DSP = DSIN(ARG) -- IPPH = (IP+1)/2 -- IPP2 = IP+2 -- IDP2 = IDO+2 -- NBD = (IDO-1)/2 -- IF (IDO .EQ. 1) GO TO 119 -- DO 101 IK=1,IDL1 -- CH2(IK,1) = C2(IK,1) -- 101 CONTINUE -- DO 103 J=2,IP -- DO 102 K=1,L1 -- CH(1,K,J) = C1(1,K,J) -- 102 CONTINUE -- 103 CONTINUE -- IF (NBD .GT. L1) GO TO 107 -- IS = -IDO -- DO 106 J=2,IP -- IS = IS+IDO -- IDIJ = IS -- DO 105 I=3,IDO,2 -- IDIJ = IDIJ+2 -- DO 104 K=1,L1 -- CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) -- CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) -- 104 CONTINUE -- 105 CONTINUE -- 106 CONTINUE -- GO TO 111 -- 107 IS = -IDO -- DO 110 J=2,IP -- IS = IS+IDO -- DO 109 K=1,L1 -- IDIJ = IS -- DO 108 I=3,IDO,2 -- IDIJ = IDIJ+2 -- CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) -- CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) -- 108 CONTINUE -- 109 CONTINUE -- 110 CONTINUE -- 111 IF (NBD .LT. L1) GO TO 115 -- DO 114 J=2,IPPH -- JC = IPP2-J -- DO 113 K=1,L1 -- DO 112 I=3,IDO,2 -- C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) -- C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) -- C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) -- C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) -- 112 CONTINUE -- 113 CONTINUE -- 114 CONTINUE -- GO TO 121 -- 115 DO 118 J=2,IPPH -- JC = IPP2-J -- DO 117 I=3,IDO,2 -- DO 116 K=1,L1 -- C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) -- C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) -- C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) -- C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) -- 116 CONTINUE -- 117 CONTINUE -- 118 CONTINUE -- GO TO 121 -- 119 DO 120 IK=1,IDL1 -- C2(IK,1) = CH2(IK,1) -- 120 CONTINUE -- 121 DO 123 J=2,IPPH -- JC = IPP2-J -- DO 122 K=1,L1 -- C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) -- C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) -- 122 CONTINUE -- 123 CONTINUE --C -- AR1 = 1.0D0 -- AI1 = 0.0D0 -- DO 127 L=2,IPPH -- LC = IPP2-L -- AR1H = DCP*AR1-DSP*AI1 -- AI1 = DCP*AI1+DSP*AR1 -- AR1 = AR1H -- DO 124 IK=1,IDL1 -- CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) -- CH2(IK,LC) = AI1*C2(IK,IP) -- 124 CONTINUE -- DC2 = AR1 -- DS2 = AI1 -- AR2 = AR1 -- AI2 = AI1 -- DO 126 J=3,IPPH -- JC = IPP2-J -- AR2H = DC2*AR2-DS2*AI2 -- AI2 = DC2*AI2+DS2*AR2 -- AR2 = AR2H -- DO 125 IK=1,IDL1 -- CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) -- CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) -- 125 CONTINUE -- 126 CONTINUE -- 127 CONTINUE -- DO 129 J=2,IPPH -- DO 128 IK=1,IDL1 -- CH2(IK,1) = CH2(IK,1)+C2(IK,J) -- 128 CONTINUE -- 129 CONTINUE --C -- IF (IDO .LT. L1) GO TO 132 -- DO 131 K=1,L1 -- DO 130 I=1,IDO -- CC(I,1,K) = CH(I,K,1) -- 130 CONTINUE -- 131 CONTINUE -- GO TO 135 -- 132 DO 134 I=1,IDO -- DO 133 K=1,L1 -- CC(I,1,K) = CH(I,K,1) -- 133 CONTINUE -- 134 CONTINUE -- 135 DO 137 J=2,IPPH -- JC = IPP2-J -- J2 = J+J -- DO 136 K=1,L1 -- CC(IDO,J2-2,K) = CH(1,K,J) -- CC(1,J2-1,K) = CH(1,K,JC) -- 136 CONTINUE -- 137 CONTINUE -- IF (IDO .EQ. 1) RETURN -- IF (NBD .LT. L1) GO TO 141 -- DO 140 J=2,IPPH -- JC = IPP2-J -- J2 = J+J -- DO 139 K=1,L1 -- DO 138 I=3,IDO,2 -- IC = IDP2-I -- CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) -- CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) -- CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) -- CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) -- 138 CONTINUE -- 139 CONTINUE -- 140 CONTINUE -- RETURN -- 141 DO 144 J=2,IPPH -- JC = IPP2-J -- J2 = J+J -- DO 143 I=3,IDO,2 -- IC = IDP2-I -- DO 142 K=1,L1 -- CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) -- CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) -- CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) -- CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) -- 142 CONTINUE -- 143 CONTINUE -- 144 CONTINUE -- RETURN -- END -- -- SUBROUTINE DFFTB1 (N,C,CH,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) -- NF = IFAC(2) -- NA = 0 -- L1 = 1 -- IW = 1 -- DO 116 K1=1,NF -- IP = IFAC(K1+2) -- L2 = IP*L1 -- IDO = N/L2 -- IDL1 = IDO*L1 -- IF (IP .NE. 4) GO TO 103 -- IX2 = IW+IDO -- IX3 = IX2+IDO -- IF (NA .NE. 0) GO TO 101 -- CALL DRADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) -- GO TO 102 -- 101 CALL DRADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) -- 102 NA = 1-NA -- GO TO 115 -- 103 IF (IP .NE. 2) GO TO 106 -- IF (NA .NE. 0) GO TO 104 -- CALL DRADB2 (IDO,L1,C,CH,WA(IW)) -- GO TO 105 -- 104 CALL DRADB2 (IDO,L1,CH,C,WA(IW)) -- 105 NA = 1-NA -- GO TO 115 -- 106 IF (IP .NE. 3) GO TO 109 -- IX2 = IW+IDO -- IF (NA .NE. 0) GO TO 107 -- CALL DRADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) -- GO TO 108 -- 107 CALL DRADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) -- 108 NA = 1-NA -- GO TO 115 -- 109 IF (IP .NE. 5) GO TO 112 -- IX2 = IW+IDO -- IX3 = IX2+IDO -- IX4 = IX3+IDO -- IF (NA .NE. 0) GO TO 110 -- CALL DRADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- GO TO 111 -- 110 CALL DRADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- 111 NA = 1-NA -- GO TO 115 -- 112 IF (NA .NE. 0) GO TO 113 -- CALL DRADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) -- GO TO 114 -- 113 CALL DRADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) -- 114 IF (IDO .EQ. 1) NA = 1-NA -- 115 L1 = L2 -- IW = IW+(IP-1)*IDO -- 116 CONTINUE -- IF (NA .EQ. 0) RETURN -- DO 117 I=1,N -- C(I) = CH(I) -- 117 CONTINUE -- RETURN -- END -- -- -- SUBROUTINE DFFTB (N,R,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION R(*) ,WSAVE(*) -- IF (N .EQ. 1) RETURN -- CALL DFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) -- RETURN -- END -- -- SUBROUTINE DFFTF1 (N,C,CH,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) -- NF = IFAC(2) -- NA = 1 -- L2 = N -- IW = N -- DO 111 K1=1,NF -- KH = NF-K1 -- IP = IFAC(KH+3) -- L1 = L2/IP -- IDO = N/L2 -- IDL1 = IDO*L1 -- IW = IW-(IP-1)*IDO -- NA = 1-NA -- IF (IP .NE. 4) GO TO 102 -- IX2 = IW+IDO -- IX3 = IX2+IDO -- IF (NA .NE. 0) GO TO 101 -- CALL DRADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) -- GO TO 110 -- 101 CALL DRADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) -- GO TO 110 -- 102 IF (IP .NE. 2) GO TO 104 -- IF (NA .NE. 0) GO TO 103 -- CALL DRADF2 (IDO,L1,C,CH,WA(IW)) -- GO TO 110 -- 103 CALL DRADF2 (IDO,L1,CH,C,WA(IW)) -- GO TO 110 -- 104 IF (IP .NE. 3) GO TO 106 -- IX2 = IW+IDO -- IF (NA .NE. 0) GO TO 105 -- CALL DRADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) -- GO TO 110 -- 105 CALL DRADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) -- GO TO 110 -- 106 IF (IP .NE. 5) GO TO 108 -- IX2 = IW+IDO -- IX3 = IX2+IDO -- IX4 = IX3+IDO -- IF (NA .NE. 0) GO TO 107 -- CALL DRADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- GO TO 110 -- 107 CALL DRADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) -- GO TO 110 -- 108 IF (IDO .EQ. 1) NA = 1-NA -- IF (NA .NE. 0) GO TO 109 -- CALL DRADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) -- NA = 1 -- GO TO 110 -- 109 CALL DRADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) -- NA = 0 -- 110 L2 = L1 -- 111 CONTINUE -- IF (NA .EQ. 1) RETURN -- DO 112 I=1,N -- C(I) = CH(I) -- 112 CONTINUE -- RETURN -- END -- -- -- SUBROUTINE DFFTF (N,R,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION R(*) ,WSAVE(*) -- IF (N .EQ. 1) RETURN -- CALL DFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) -- RETURN -- END -- -- SUBROUTINE DFFTI1 (N,WA,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) -- DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ -- NL = N -- NF = 0 -- J = 0 -- 101 J = J+1 -- IF (J-4) 102,102,103 -- 102 NTRY = NTRYH(J) -- GO TO 104 -- 103 NTRY = NTRY+2 -- 104 NQ = NL/NTRY -- NR = NL-NTRY*NQ -- IF (NR) 101,105,101 -- 105 NF = NF+1 -- IFAC(NF+2) = NTRY -- NL = NQ -- IF (NTRY .NE. 2) GO TO 107 -- IF (NF .EQ. 1) GO TO 107 -- DO 106 I=2,NF -- IB = NF-I+2 -- IFAC(IB+2) = IFAC(IB+1) -- 106 CONTINUE -- IFAC(3) = 2 -- 107 IF (NL .NE. 1) GO TO 104 -- IFAC(1) = N -- IFAC(2) = NF -- TPI = 6.2831853071795864769252867665590057D0 -- ARGH = TPI/DBLE(N) -- IS = 0 -- NFM1 = NF-1 -- L1 = 1 -- IF (NFM1 .EQ. 0) RETURN -- DO 110 K1=1,NFM1 -- IP = IFAC(K1+2) -- LD = 0 -- L2 = L1*IP -- IDO = N/L2 -- IPM = IP-1 -- DO 109 J=1,IPM -- LD = LD+L1 -- I = IS -- ARGLD = DBLE(LD)*ARGH -- FI = 0.0D0 -- DO 108 II=3,IDO,2 -- I = I+2 -- FI = FI+1.0D0 -- ARG = FI*ARGLD -- WA(I-1) = DCOS(ARG) -- WA(I) = DSIN(ARG) -- 108 CONTINUE -- IS = IS+IDO -- 109 CONTINUE -- L1 = L2 -- 110 CONTINUE -- RETURN -- END -- -- SUBROUTINE DFFTI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- IF (N .EQ. 1) RETURN -- CALL DFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) -- RETURN -- END -- SUBROUTINE DSINQB (N,X,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,WSAVE(*) -- IF (N .GT. 1) GO TO 101 -- X(1) = 4.0D0*X(1) -- RETURN -- 101 NS2 = N/2 -- DO 102 K=2,N,2 -- X(K) = -X(K) -- 102 CONTINUE -- CALL DCOSQB (N,X,WSAVE) -- DO 103 K=1,NS2 -- KC = N-K -- XHOLD = X(K) -- X(K) = X(KC+1) -- X(KC+1) = XHOLD -- 103 CONTINUE -- RETURN -- END -- SUBROUTINE DSINQF (N,X,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,WSAVE(*) -- IF (N .EQ. 1) RETURN -- NS2 = N/2 -- DO 101 K=1,NS2 -- KC = N-K -- XHOLD = X(K) -- X(K) = X(KC+1) -- X(KC+1) = XHOLD -- 101 CONTINUE -- CALL DCOSQF (N,X,WSAVE) -- DO 102 K=2,N,2 -- X(K) = -X(K) -- 102 CONTINUE -- RETURN -- END -- SUBROUTINE DSINQI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- CALL DCOSQI (N,WSAVE) -- RETURN -- END -- -- SUBROUTINE DSINT1(N,WAR,WAS,XH,X,IFAC) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WAR(*),WAS(*),X(*),XH(*),IFAC(*) -- DATA SQRT3 /1.7320508075688772935274463415058723D0/ -- DO 100 I=1,N -- XH(I) = WAR(I) -- WAR(I) = X(I) -- 100 CONTINUE -- IF (N-2) 101,102,103 -- 101 XH(1) = XH(1)+XH(1) -- GO TO 106 -- 102 XHOLD = SQRT3*(XH(1)+XH(2)) -- XH(2) = SQRT3*(XH(1)-XH(2)) -- XH(1) = XHOLD -- GO TO 106 -- 103 NP1 = N+1 -- NS2 = N/2 -- X(1) = 0.0D0 -- DO 104 K=1,NS2 -- KC = NP1-K -- T1 = XH(K)-XH(KC) -- T2 = WAS(K)*(XH(K)+XH(KC)) -- X(K+1) = T1+T2 -- X(KC+1) = T2-T1 -- 104 CONTINUE -- MODN = MOD(N,2) -- IF (MODN .NE. 0) X(NS2+2) = 4.0D0*XH(NS2+1) -- CALL DFFTF1 (NP1,X,XH,WAR,IFAC) -- XH(1) = .5D0*X(1) -- DO 105 I=3,N,2 -- XH(I-1) = -X(I) -- XH(I) = XH(I-2)+X(I-1) -- 105 CONTINUE -- IF (MODN .NE. 0) GO TO 106 -- XH(N) = -X(N+1) -- 106 DO 107 I=1,N -- X(I) = WAR(I) -- WAR(I) = XH(I) -- 107 CONTINUE -- RETURN -- END -- -- SUBROUTINE DSINT (N,X,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION X(*) ,WSAVE(*) -- NP1 = N+1 -- IW1 = N/2+1 -- IW2 = IW1+NP1 -- IW3 = IW2+NP1 -- CALL DSINT1(N,X,WSAVE,WSAVE(IW1),WSAVE(IW2),WSAVE(IW3)) -- RETURN -- END -- -- SUBROUTINE DSINTI (N,WSAVE) -- IMPLICIT DOUBLE PRECISION (A-H,O-Z) -- DIMENSION WSAVE(*) -- DATA PI /3.1415926535897932384626433832795028D0/ -- IF (N .LE. 1) RETURN -- NS2 = N/2 -- NP1 = N+1 -- DT = PI/DBLE(NP1) -- DO 101 K=1,NS2 -- WSAVE(K) = 2.0D0*DSIN(K*DT) -- 101 CONTINUE -- CALL DFFTI (NP1,WSAVE(NS2+1)) -- RETURN -- END -diff --git a/scipy/linalg/src/id_dist/src/id_rand.f b/scipy/linalg/src/id_dist/src/id_rand.f -deleted file mode 100644 -index b49d2ef1f..000000000 ---- a/scipy/linalg/src/id_dist/src/id_rand.f -+++ /dev/null -@@ -1,379 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine id_frand generates pseudorandom numbers --c drawn uniformly from [0,1]. id_frand is more --c efficient that id_srand, but cannot generate --c fewer than 55 pseudorandom numbers per call. --c --c routine id_srand generates pseudorandom numbers --c drawn uniformly from [0,1]. id_srand is less --c efficient that id_frand, but can generate --c fewer than 55 pseudorandom numbers per call. --c --c entry id_frandi initializes the seed values --c for routine id_frand. --c --c entry id_srandi initializes the seed values --c for routine id_srand. --c --c entry id_frando initializes the seed values --c for routine id_frand to their original values. --c --c entry id_srando initializes the seed values --c for routine id_srand to their original values. --c --c routine id_randperm generates a uniformly random permutation. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine id_frand(n,r) --c --c generates n pseudorandom numbers drawn uniformly from [0,1], --c via a very efficient lagged Fibonnaci method. --c Unlike routine id_srand, the present routine requires that --c n be at least 55. --c --c input: --c n -- number of pseudorandom numbers to generate --c --c output: --c r -- array of pseudorandom numbers --c --c _N.B._: n must be at least 55. --c --c reference: --c Press, Teukolsky, Vetterling, Flannery, "Numerical Recipes," --c 3rd edition, Cambridge University Press, 2007, --c Section 7.1.5. --c -- implicit none -- integer n,k -- real*8 r(n),s(55),t(55),s0(55),x -- save --c -- data s/ -- 1 0.2793574644042651d0, 0.1882566493961346d0, -- 2 0.5202478134503912d0, 0.7568505373052146d0, -- 3 0.5682465992936152d0, 0.5153148754383294d0, -- 4 0.7806554095454596d0, 1.982474428974643d-2, -- 5 0.2520464262278498d0, 0.6423784715775962d0, -- 6 0.5802024387972178d0, 0.3784471040388249d0, -- 7 7.839919528229308d-2, 0.6334519212594525d0, -- 8 3.387627157788001d-2, 0.1709066283884670d0, -- 9 0.4801610983518325d0, 0.8983424668099422d0, -- * 5.358948687598758d-2, 0.1265377231771848d0, -- 1 0.8979988627693677d0, 0.6470084038238917d0, -- 2 0.3031709395541237d0, 0.6674702804438126d0, -- 3 0.6318240977112699d0, 0.2235229633873050d0, -- 4 0.2784629939177633d0, 0.2365462014457445d0, -- 5 0.7226213454977284d0, 0.8986523045307989d0, -- 6 0.5488233229247885d0, 0.3924605412141200d0, -- 7 0.6288356378374988d0, 0.6370664115760445d0, -- 8 0.5925600062791174d0, 0.4322113919396362d0, -- 9 0.9766098520360393d0, 0.5168619893947437d0, -- * 0.6799970440779681d0, 0.4196004604766881d0, -- 1 0.2324473089903044d0, 0.1439046416143282d0, -- 2 0.4670307948601256d0, 0.7076498261128343d0, -- 3 0.9458030397562582d0, 0.4557892460080424d0, -- 4 0.3905930854589403d0, 0.3361770064397268d0, -- 5 0.8303274937900278d0, 0.3041110304032945d0, -- 6 0.5752684022049654d0, 7.985703137991175d-2, -- 7 0.5522643936454465d0, 1.956754937251801d-2, -- 8 0.9920272858340107d0/ --c -- data s0/ -- 1 0.2793574644042651d0, 0.1882566493961346d0, -- 2 0.5202478134503912d0, 0.7568505373052146d0, -- 3 0.5682465992936152d0, 0.5153148754383294d0, -- 4 0.7806554095454596d0, 1.982474428974643d-2, -- 5 0.2520464262278498d0, 0.6423784715775962d0, -- 6 0.5802024387972178d0, 0.3784471040388249d0, -- 7 7.839919528229308d-2, 0.6334519212594525d0, -- 8 3.387627157788001d-2, 0.1709066283884670d0, -- 9 0.4801610983518325d0, 0.8983424668099422d0, -- * 5.358948687598758d-2, 0.1265377231771848d0, -- 1 0.8979988627693677d0, 0.6470084038238917d0, -- 2 0.3031709395541237d0, 0.6674702804438126d0, -- 3 0.6318240977112699d0, 0.2235229633873050d0, -- 4 0.2784629939177633d0, 0.2365462014457445d0, -- 5 0.7226213454977284d0, 0.8986523045307989d0, -- 6 0.5488233229247885d0, 0.3924605412141200d0, -- 7 0.6288356378374988d0, 0.6370664115760445d0, -- 8 0.5925600062791174d0, 0.4322113919396362d0, -- 9 0.9766098520360393d0, 0.5168619893947437d0, -- * 0.6799970440779681d0, 0.4196004604766881d0, -- 1 0.2324473089903044d0, 0.1439046416143282d0, -- 2 0.4670307948601256d0, 0.7076498261128343d0, -- 3 0.9458030397562582d0, 0.4557892460080424d0, -- 4 0.3905930854589403d0, 0.3361770064397268d0, -- 5 0.8303274937900278d0, 0.3041110304032945d0, -- 6 0.5752684022049654d0, 7.985703137991175d-2, -- 7 0.5522643936454465d0, 1.956754937251801d-2, -- 8 0.9920272858340107d0/ --c --c -- do k = 1,24 --c -- x = s(k+31)-s(k) -- if(x .lt. 0) x = x+1 -- r(k) = x --c -- enddo ! k --c --c -- do k = 25,55 --c -- x = r(k-24)-s(k) -- if(x .lt. 0) x = x+1 -- r(k) = x --c -- enddo ! k --c --c -- do k = 56,n --c -- x = r(k-24)-r(k-55) -- if(x .lt. 0) x = x+1 -- r(k) = x --c -- enddo ! k --c --c -- do k = 1,55 -- s(k) = r(n-55+k) -- enddo ! k --c --c -- return --c --c --c -- entry id_frandi(t) --c --c initializes the seed values in s --c (any appropriately random numbers will do). --c --c input: --c t -- values to copy into s --c -- do k = 1,55 -- s(k) = t(k) -- enddo ! k --c -- return --c --c --c -- entry id_frando() --c --c initializes the seed values in s to their original values. --c -- do k = 1,55 -- s(k) = s0(k) -- enddo ! k --c -- return -- end --c --c --c --c -- subroutine id_srand(n,r) --c --c generates n pseudorandom numbers drawn uniformly from [0,1], --c via a very efficient lagged Fibonnaci method. --c Unlike routine id_frand, the present routine does not requires --c that n be at least 55. --c --c input: --c n -- number of pseudorandom numbers to generate --c --c output: --c r -- array of pseudorandom numbers --c --c reference: --c Press, Teukolsky, Vetterling, Flannery, "Numerical Recipes," --c 3rd edition, Cambridge University Press, 2007, --c Section 7.1.5. --c -- implicit none -- integer n,k,l,m -- real*8 s(55),r(n),s0(55),t(55),x -- save --c -- data l/55/,m/24/ --c -- data s/ -- 1 0.8966049453474352d0, 0.7789471911260157d0, -- 2 0.6071529762908476d0, 0.8287077988663865d0, -- 3 0.8249336255502409d0, 0.5735259423199479d0, -- 4 0.2436346323812991d0, 0.2656149927259701d0, -- 5 0.6594784809929011d0, 0.3432392503145575d0, -- 6 0.5051287353012308d0, 0.1444493249757482d0, -- 7 0.7643753221285416d0, 0.4843422506977382d0, -- 8 0.4427513254774826d0, 0.2965991475108561d0, -- 9 0.2650513544474467d0, 2.768759325778929d-2, -- * 0.6106305243078063d0, 0.4246918885003141d0, -- 1 0.2863757386932874d0, 0.6211983878375777d0, -- 2 0.7534336463880467d0, 0.7471458603576737d0, -- 3 0.2017455446928328d0, 0.9334235874832779d0, -- 4 0.6343440435422822d0, 0.8819824804812527d0, -- 5 1.994761401222460d-2, 0.7023693520374801d0, -- 6 0.6010088924817263d0, 6.498095955562046d-2, -- 7 0.3090915456102685d0, 0.3014924769096677d0, -- 8 0.5820726822705102d0, 0.3630527222866207d0, -- 9 0.3787166916242271d0, 0.3932772088505305d0, -- * 0.5570720335382000d0, 0.9712062146993835d0, -- 1 0.1338293907964648d0, 0.1857441593107195d0, -- 2 0.9102503893692572d0, 0.2623337538798778d0, -- 3 0.3542828591321135d0, 2.246286032456513d-2, -- 4 0.7935703170405717d0, 6.051464729640567d-2, -- 5 0.7271929955172147d0, 1.968513010678739d-3, -- 6 0.4914223624495486d0, 0.8730023176789450d0, -- 7 0.9639777091743168d0, 0.1084256187532446d0, -- 8 0.8539399636754000d0/ --c -- data s0/ -- 1 0.8966049453474352d0, 0.7789471911260157d0, -- 2 0.6071529762908476d0, 0.8287077988663865d0, -- 3 0.8249336255502409d0, 0.5735259423199479d0, -- 4 0.2436346323812991d0, 0.2656149927259701d0, -- 5 0.6594784809929011d0, 0.3432392503145575d0, -- 6 0.5051287353012308d0, 0.1444493249757482d0, -- 7 0.7643753221285416d0, 0.4843422506977382d0, -- 8 0.4427513254774826d0, 0.2965991475108561d0, -- 9 0.2650513544474467d0, 2.768759325778929d-2, -- * 0.6106305243078063d0, 0.4246918885003141d0, -- 1 0.2863757386932874d0, 0.6211983878375777d0, -- 2 0.7534336463880467d0, 0.7471458603576737d0, -- 3 0.2017455446928328d0, 0.9334235874832779d0, -- 4 0.6343440435422822d0, 0.8819824804812527d0, -- 5 1.994761401222460d-2, 0.7023693520374801d0, -- 6 0.6010088924817263d0, 6.498095955562046d-2, -- 7 0.3090915456102685d0, 0.3014924769096677d0, -- 8 0.5820726822705102d0, 0.3630527222866207d0, -- 9 0.3787166916242271d0, 0.3932772088505305d0, -- * 0.5570720335382000d0, 0.9712062146993835d0, -- 1 0.1338293907964648d0, 0.1857441593107195d0, -- 2 0.9102503893692572d0, 0.2623337538798778d0, -- 3 0.3542828591321135d0, 2.246286032456513d-2, -- 4 0.7935703170405717d0, 6.051464729640567d-2, -- 5 0.7271929955172147d0, 1.968513010678739d-3, -- 6 0.4914223624495486d0, 0.8730023176789450d0, -- 7 0.9639777091743168d0, 0.1084256187532446d0, -- 8 0.8539399636754000d0/ --c --c -- do k = 1,n --c --c Run one step of the recurrence. --c -- x = s(m)-s(l) -- if(x .lt. 0) x = x+1 -- s(l) = x -- r(k) = x --c --c Decrement l and m. --c -- l = l-1 -- m = m-1 --c --c Circle back to the end if required. --c -- if(l .eq. 0) l = 55 -- if(m .eq. 0) m = 55 --c -- enddo ! k --c --c -- return --c --c --c -- entry id_srandi(t) --c --c initializes the seed values in s --c (any appropriately random numbers will do). --c --c input: --c t -- values to copy into s --c -- do k = 1,55 -- s(k) = t(k) -- enddo ! k --c -- l = 55 -- m = 24 --c -- return --c --c --c -- entry id_srando() --c --c initializes the seed values in s to their original values. --c -- do k = 1,55 -- s(k) = s0(k) -- enddo ! k --c -- l = 55 -- m = 24 --c -- return -- end --c --c --c --c -- subroutine id_randperm(n,ind) --c --c draws a permutation ind uniformly at random from the group --c of all permutations of n objects. --c --c input: --c n -- length of ind --c --c output: --c ind -- random permutation of length n --c -- implicit none -- integer n,ind(n),m,j,iswap -- real*8 r --c --c --c Initialize ind. --c -- do j = 1,n -- ind(j) = j -- enddo ! j --c --c --c Shuffle ind via the Fisher-Yates (Knuth/Durstenfeld) algorithm. --c -- do m = n,2,-1 --c --c Draw an integer uniformly at random from 1, 2, ..., m. --c -- call id_srand(1,r) -- j = m*r+1 --c --c Uncomment the following line if r could equal 1: --c if(j .eq. m+1) j = m --c --c Swap ind(j) and ind(m). --c -- iswap = ind(j) -- ind(j) = ind(m) -- ind(m) = iswap --c -- enddo ! m --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/id_rtrans.f b/scipy/linalg/src/id_dist/src/id_rtrans.f -deleted file mode 100644 -index a970d7fb5..000000000 ---- a/scipy/linalg/src/id_dist/src/id_rtrans.f -+++ /dev/null -@@ -1,746 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idd_random_transf applies rapidly --c a random orthogonal matrix to a user-supplied vector. --c --c routine idd_random_transf_inverse applies rapidly --c the inverse of the operator applied --c by routine idd_random_transf. --c --c routine idz_random_transf applies rapidly --c a random unitary matrix to a user-supplied vector. --c --c routine idz_random_transf_inverse applies rapidly --c the inverse of the operator applied --c by routine idz_random_transf. --c --c routine idd_random_transf_init initializes data --c for routines idd_random_transf and idd_random_transf_inverse. --c --c routine idz_random_transf_init initializes data --c for routines idz_random_transf and idz_random_transf_inverse. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c --c -- subroutine idd_random_transf_init(nsteps,n,w,keep) -- implicit real *8 (a-h,o-z) -- save -- dimension w(*) --c --c prepares and stores in array w the data used --c by the routines idd_random_transf and idd_random_transf_inverse --c to apply rapidly a random orthogonal matrix --c to an arbitrary user-specified vector. --c --c input: --c nsteps -- the degree of randomness of the operator --c to be applied --c n -- the size of the matrix to be applied --c --c output: --c w -- the first keep elements of w contain all the data --c to be used by routines idd_random_tranf --c and idd_random_transf_inverse. Please note that --c the number of elements used by the present routine --c is also equal to keep. This array should be at least --c 3*nsteps*n + 2*n + n/4 + 50 real*8 elements long. --c keep - the number of elements in w actually used --c by the present routine; keep is also the number --c of elements that must not be changed between the call --c to this routine and subsequent calls to routines --c idd_random_transf and idd_random_transf_inverse. --c --c --c . . . allocate memory --c -- ninire=2 --c -- ialbetas=10 -- lalbetas=2*n*nsteps+10 --c -- iixs=ialbetas+lalbetas -- lixs=n*nsteps/ninire+10 --c -- iww=iixs+lixs -- lww=2*n+n/4+20 --c -- keep=iww+lww --c -- w(1)=ialbetas+0.1 -- w(2)=iixs+0.1 -- w(3)=nsteps+0.1 -- w(4)=iww+0.1 -- w(5)=n+0.1 --c -- call idd_random_transf_init0(nsteps,n,w(ialbetas),w(iixs)) --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf_init(nsteps,n,w,keep) -- implicit real *8 (a-h,o-z) -- save -- dimension w(*) --c --c prepares and stores in array w the data used --c by routines idz_random_transf and idz_random_transf_inverse --c to apply rapidly a random unitary matrix --c to an arbitrary user-specified vector. --c --c input: --c nsteps -- the degree of randomness of the operator --c to be applied --c n -- the size of the matrix to be applied --c --c output: --c w -- the first keep elements of w contain all the data --c to be used by routines idz_random_transf --c and idz_random_transf_inverse. Please note that --c the number of elements used by the present routine --c is also equal to keep. This array should be at least --c 5*nsteps*n + 2*n + n/4 + 60 real*8 elements long. --c keep - the number of elements in w actually used --c by the present routine; keep is also the number --c of elements that must not be changed between the call --c to this routine and subsequent calls to routines --c idz_random_transf and idz_random_transf_inverse. --c --c --c . . . allocate memory --c -- ninire=2 --c -- ialbetas=10 -- lalbetas=2*n*nsteps+10 --c -- igammas=ialbetas+lalbetas -- lgammas=2*n*nsteps+10 --c -- iixs=igammas+lgammas -- lixs=n*nsteps/ninire+10 --c -- iww=iixs+lixs -- lww=2*n+n/4+20 --c -- keep=iww+lww --c -- w(1)=ialbetas+0.1 -- w(2)=iixs+0.1 -- w(3)=nsteps+0.1 -- w(4)=iww+0.1 -- w(5)=n+0.1 -- w(6)=igammas+0.1 --c -- call idz_random_transf_init0(nsteps,n,w(ialbetas), -- 1 w(igammas),w(iixs)) --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf(x,y,w) -- implicit real *8 (a-h,o-z) -- save -- dimension x(*),y(*),w(*) --c --c applies rapidly a random orthogonal matrix --c to the user-specified real vector x, --c using the data in array w stored there by a preceding --c call to routine idd_random_transf_init. --c --c input: --c x -- the vector of length n to which the random matrix is --c to be applied --c w -- array containing all initialization data --c --c output: --c y -- the result of applying the random matrix to x --c --c --c . . . allocate memory --c -- ialbetas=w(1) -- iixs=w(2) -- nsteps=w(3) -- iww=w(4) -- n=w(5) --c -- call idd_random_transf0(nsteps,x,y,n,w(iww), -- 1 w(ialbetas),w(iixs)) --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf_inverse(x,y,w) -- implicit real *8 (a-h,o-z) -- save -- dimension x(*),y(*),w(*) --c --c applies rapidly a random orthogonal matrix --c to the user-specified real vector x, --c using the data in array w stored there by a preceding --c call to routine idd_random_transf_init. --c The transformation applied by the present routine is --c the inverse of the transformation applied --c by routine idd_random_transf. --c --c input: --c x -- the vector of length n to which the random matrix is --c to be applied --c w -- array containing all initialization data --c --c output: --c y -- the result of applying the random matrix to x --c --c --c . . . allocate memory --c -- ialbetas=w(1) -- iixs=w(2) -- nsteps=w(3) -- iww=w(4) -- n=w(5) --c -- call idd_random_transf0_inv(nsteps,x,y,n,w(iww), -- 1 w(ialbetas),w(iixs)) --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf(x,y,w) -- implicit real *8 (a-h,o-z) -- save -- complex *16 x(*),y(*) -- dimension w(*) --c --c applies rapidly a random unitary matrix --c to the user-specified vector x, --c using the data in array w stored there by a preceding --c call to routine idz_random_transf_init. --c --c input: --c x -- the vector of length n to which the random matrix is --c to be applied --c w -- array containing all initialization data --c --c output: --c y -- the result of applying the random matrix to x --c --c --c . . . allocate memory --c -- ialbetas=w(1) -- iixs=w(2) -- nsteps=w(3) -- iww=w(4) -- n=w(5) -- igammas=w(6) --c -- call idz_random_transf0(nsteps,x,y,n,w(iww),w(ialbetas), -- 1 w(igammas),w(iixs)) --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf_inverse(x,y,w) -- implicit real *8 (a-h,o-z) -- save -- complex *16 x(*),y(*) -- dimension w(*) --c --c applies rapidly a random unitary matrix --c to the user-specified vector x, --c using the data in array w stored there by a preceding --c call to routine idz_random_transf_init. --c The transformation applied by the present routine is --c the inverse of the transformation applied --c by routine idz_random_transf. --c --c input: --c x -- the vector of length n to which the random matrix is --c to be applied --c w -- array containing all initialization data --c --c output: --c y -- the result of applying the random matrix to x --c --c --c . . . allocate memory --c -- ialbetas=w(1) -- iixs=w(2) -- nsteps=w(3) -- iww=w(4) -- n=w(5) -- igammas=w(6) --c -- call idz_random_transf0_inv(nsteps,x,y,n,w(iww), -- 1 w(ialbetas),w(igammas),w(iixs)) --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf0_inv(nsteps,x,y,n,w2,albetas,iixs) -- implicit real *8 (a-h,o-z) -- save -- dimension x(*),y(*),w2(*),albetas(2,n,*),iixs(n,*) --c --c routine idd_random_transf_inverse serves as a memory wrapper --c for the present routine; see routine idd_random_transf_inverse --c for documentation. --c -- do 1200 i=1,n --c -- w2(i)=x(i) -- 1200 continue --c -- do 2000 ijk=nsteps,1,-1 --c -- call idd_random_transf00_inv(w2,y,n,albetas(1,1,ijk), -- 1 iixs(1,ijk) ) --c -- do 1400 j=1,n --c -- w2(j)=y(j) -- 1400 continue -- 2000 continue --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf00_inv(x,y,n,albetas,ixs) -- implicit real *8 (a-h,o-z) -- save -- dimension x(*),y(*),albetas(2,*),ixs(*) --c --c implements one step of the random transform required --c by routine idd_random_transf0_inv (please see the latter). --c --c --c implement 2 \times 2 matrices --c -- do 1600 i=1,n -- y(i)=x(i) -- 1600 continue --c -- do 1800 i=n-1,1,-1 --c -- alpha=albetas(1,i) -- beta=albetas(2,i) --c -- a=y(i) -- b=y(i+1) --c -- y(i)=alpha*a-beta*b -- y(i+1)=beta*a+alpha*b -- 1800 continue --c --c implement the permutation --c -- do 2600 i=1,n --c -- j=ixs(i) -- x(j)=y(i) -- 2600 continue --c -- do 2800 i=1,n --c -- y(i)=x(i) -- 2800 continue --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf0_inv(nsteps,x,y,n,w2,albetas, -- 1 gammas,iixs) -- implicit real *8 (a-h,o-z) -- save -- complex *16 x(*),y(*),w2(*),gammas(n,*) -- dimension albetas(2,n,*),iixs(n,*) --c --c routine idz_random_transf_inverse serves as a memory wrapper --c for the present routine; please see routine --c idz_random_transf_inverse for documentation. --c -- do 1200 i=1,n --c -- w2(i)=x(i) -- 1200 continue --c -- do 2000 ijk=nsteps,1,-1 --c -- call idz_random_transf00_inv(w2,y,n,albetas(1,1,ijk), -- 1 gammas(1,ijk),iixs(1,ijk) ) --c -- do 1400 j=1,n --c -- w2(j)=y(j) -- 1400 continue -- 2000 continue --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf00_inv(x,y,n,albetas,gammas,ixs) -- implicit real *8 (a-h,o-z) -- save -- complex *16 x(*),y(*),gammas(*),a,b -- dimension albetas(2,*),ixs(*) --c --c implements one step of the random transform --c required by routine idz_random_transf0_inv --c (please see the latter). --c --c implement 2 \times 2 matrices --c -- do 1600 i=n-1,1,-1 --c -- alpha=albetas(1,i) -- beta=albetas(2,i) --c -- a=x(i) -- b=x(i+1) --c -- x(i)=alpha*a-beta*b -- x(i+1)=beta*a+alpha*b -- 1600 continue --c --c implement the permutation --c and divide by the random numbers on the unit circle --c (or, equivalently, multiply by their conjugates) --c -- do 1800 i=1,n --c -- j=ixs(i) -- y(j)=x(i)*conjg(gammas(i)) -- 1800 continue --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf0(nsteps,x,y,n,w2,albetas,iixs) -- implicit real *8 (a-h,o-z) -- save -- dimension x(*),y(*),w2(*),albetas(2,n,*),iixs(n,*) --c --c routine idd_random_transf serves as a memory wrapper --c for the present routine; please see routine idd_random_transf --c for documentation. --c -- do 1200 i=1,n --c -- w2(i)=x(i) -- 1200 continue --c -- do 2000 ijk=1,nsteps --c -- call idd_random_transf00(w2,y,n,albetas(1,1,ijk),iixs(1,ijk) ) --c -- do 1400 j=1,n --c -- w2(j)=y(j) -- 1400 continue -- 2000 continue --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf00(x,y,n,albetas,ixs) -- implicit real *8 (a-h,o-z) -- save -- dimension x(*),y(*),albetas(2,*),ixs(*) --c --c implements one step of the random transform --c required by routine idd_random_transf0 (please see the latter). --c --c implement the permutation --c -- do 1600 i=1,n --c -- j=ixs(i) -- y(i)=x(j) -- 1600 continue --c --c implement 2 \times 2 matrices --c -- do 1800 i=1,n-1 --c -- alpha=albetas(1,i) -- beta=albetas(2,i) --c -- a=y(i) -- b=y(i+1) --c -- y(i)=alpha*a+beta*b -- y(i+1)=-beta*a+alpha*b -- 1800 continue --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf_init0(nsteps,n,albetas,gammas,ixs) -- implicit real *8 (a-h,o-z) -- save -- dimension albetas(2,n,*),ixs(n,*) -- complex *16 gammas(n,*) --c --c routine idz_random_transf_init serves as a memory wrapper --c for the present routine; please see routine --c idz_random_transf_init for documentation. --c -- do 2000 ijk=1,nsteps --c -- call idz_random_transf_init00(n,albetas(1,1,ijk), -- 1 gammas(1,ijk),ixs(1,ijk) ) -- 2000 continue -- return -- end --c --c --c --c --c -- subroutine idz_random_transf_init00(n,albetas,gammas,ixs) -- implicit real *8 (a-h,o-z) -- save -- dimension albetas(2,*),gammas(*),ixs(*) --c --c constructs one stage of the random transform --c initialized by routine idz_random_transf_init0 --c (please see the latter). --c -- done=1 -- twopi=2*4*atan(done) --c --c construct the random permutation --c -- ifrepeat=0 -- call id_randperm(n,ixs) --c --c construct the random variables --c -- call id_srand(2*n,albetas) -- call id_srand(2*n,gammas) --c -- do 1300 i=1,n --c -- albetas(1,i)=2*albetas(1,i)-1 -- albetas(2,i)=2*albetas(2,i)-1 -- gammas(2*i-1)=2*gammas(2*i-1)-1 -- gammas(2*i)=2*gammas(2*i)-1 -- 1300 continue --c --c construct the random 2 \times 2 transformations --c -- do 1400 i=1,n --c -- d=albetas(1,i)**2+albetas(2,i)**2 -- d=1/sqrt(d) -- albetas(1,i)=albetas(1,i)*d -- albetas(2,i)=albetas(2,i)*d -- 1400 continue --c --c construct the random multipliers on the unit circle --c -- do 1500 i=1,n --c -- d=gammas(2*i-1)**2+gammas(2*i)**2 -- d=1/sqrt(d) --c --c fill the real part --c -- gammas(2*i-1)=gammas(2*i-1)*d --c --c fill the imaginary part --c -- gammas(2*i)=gammas(2*i)*d -- 1500 continue --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf0(nsteps,x,y,n,w2,albetas, -- 1 gammas,iixs) -- implicit real *8 (a-h,o-z) -- save -- complex *16 x(*),y(*),w2(*),gammas(n,*) -- dimension albetas(2,n,*),iixs(n,*) --c --c routine idz_random_transf serves as a memory wrapper --c for the present routine; please see routine idz_random_transf --c for documentation. --c -- do 1200 i=1,n --c -- w2(i)=x(i) -- 1200 continue --c -- do 2000 ijk=1,nsteps --c -- call idz_random_transf00(w2,y,n,albetas(1,1,ijk), -- 1 gammas(1,ijk),iixs(1,ijk) ) -- do 1400 j=1,n --c -- w2(j)=y(j) -- 1400 continue -- 2000 continue --c -- return -- end --c --c --c --c --c -- subroutine idz_random_transf00(x,y,n,albetas,gammas,ixs) -- implicit real *8 (a-h,o-z) -- save -- complex *16 x(*),y(*),gammas(*),a,b -- dimension albetas(2,*),ixs(*) --c --c implements one step of the random transform --c required by routine idz_random_transf0 (please see the latter). --c --c implement the permutation --c and multiply by the random numbers --c on the unit circle --c -- do 1600 i=1,n --c -- j=ixs(i) -- y(i)=x(j)*gammas(i) -- 1600 continue --c --c implement 2 \times 2 matrices --c -- do 2600 i=1,n-1 --c -- alpha=albetas(1,i) -- beta=albetas(2,i) --c -- a=y(i) -- b=y(i+1) --c -- y(i)=alpha*a+beta*b -- y(i+1)=-beta*a+alpha*b -- 2600 continue --c -- return -- end --c --c --c --c --c -- subroutine idd_random_transf_init0(nsteps,n,albetas,ixs) -- implicit real *8 (a-h,o-z) -- save -- dimension albetas(2,n,*),ixs(n,*) --c --c routine idd_random_transf_init serves as a memory wrapper --c for the present routine; please see routine --c idd_random_transf_init for documentation. --c -- do 2000 ijk=1,nsteps --c -- call idd_random_transf_init00(n,albetas(1,1,ijk),ixs(1,ijk) ) -- 2000 continue -- return -- end --c --c --c --c --c -- subroutine idd_random_transf_init00(n,albetas,ixs) -- implicit real *8 (a-h,o-z) -- save -- dimension albetas(2,*),ixs(*) --c --c constructs one stage of the random transform --c initialized by routine idd_random_transf_init0 --c (please see the latter). --c --c construct the random permutation --c -- ifrepeat=0 -- call id_randperm(n,ixs) --c --c construct the random variables --c -- call id_srand(2*n,albetas) --c -- do 1300 i=1,n --c -- albetas(1,i)=2*albetas(1,i)-1 -- albetas(2,i)=2*albetas(2,i)-1 -- 1300 continue --c --c construct the random 2 \times 2 transformations --c -- do 1400 i=1,n --c -- d=albetas(1,i)**2+albetas(2,i)**2 -- d=1/sqrt(d) -- albetas(1,i)=albetas(1,i)*d -- albetas(2,i)=albetas(2,i)*d -- 1400 continue -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_frm.f b/scipy/linalg/src/id_dist/src/idd_frm.f -deleted file mode 100644 -index 0a13112eb..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_frm.f -+++ /dev/null -@@ -1,525 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idd_frm transforms a vector via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c --c routine idd_sfrm transforms a vector into a vector --c of specified length via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c --c routine idd_frmi initializes routine idd_frm. --c --c routine idd_sfrmi initializes routine idd_sfrm. --c --c routine idd_pairsamps calculates the indices of the pairs --c of integers to which the individual integers --c in a specified set belong. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idd_frm(m,n,w,x,y) --c --c transforms x into y via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c In contrast to routine idd_sfrm, the present routine works best --c when the length of the transformed vector is the integer n --c output by routine idd_frmi, or when the length --c is not specified, but instead determined a posteriori --c using the output of the present routine. The transformed vector --c output by the present routine is randomly permuted. --c --c input: --c m -- length of x --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m, as obtained --c from the routine idd_frmi; n is the length of y --c w -- initialization array constructed by routine idd_frmi --c x -- vector to be transformed --c --c output: --c y -- transform of x --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,iw,n,k -- real*8 w(17*m+70),x(m),y(n) --c --c --c Apply Rokhlin's random transformation to x, obtaining --c w(16*m+71 : 17*m+70). --c -- iw = w(3+m+n) -- call idd_random_transf(x,w(16*m+70+1),w(iw)) --c --c --c Subselect from w(16*m+71 : 17*m+70) to obtain y. --c -- call idd_subselect(n,w(3),m,w(16*m+70+1),y) --c --c --c Copy y into w(16*m+71 : 16*m+n+70). --c -- do k = 1,n -- w(16*m+70+k) = y(k) -- enddo ! k --c --c --c Fourier transform w(16*m+71 : 16*m+n+70). --c -- call dfftf(n,w(16*m+70+1),w(4+m+n)) --c --c --c Permute w(16*m+71 : 16*m+n+70) to obtain y. --c -- call idd_permute(n,w(3+m),w(16*m+70+1),y) --c --c -- return -- end --c --c --c --c -- subroutine idd_sfrm(l,m,n,w,x,y) --c --c transforms x into y via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c In contrast to routine idd_frm, the present routine works best --c when the length l of the transformed vector is known a priori. --c --c input: --c l -- length of y; l must be less than or equal to n --c m -- length of x --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m, as obtained --c from the routine idd_sfrmi --c w -- initialization array constructed by routine idd_sfrmi --c x -- vector to be transformed --c --c output: --c y -- transform of x --c --c _N.B._: l must be less than or equal to n. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,iw,n,l,l2 -- real*8 w(27*m+90),x(m),y(l) --c --c --c Retrieve the number of pairs of outputs to be calculated --c via sfft. --c -- l2 = w(3) --c --c --c Apply Rokhlin's random transformation to x, obtaining --c w(25*m+91 : 26*m+90). --c -- iw = w(4+m+l+l2) -- call idd_random_transf(x,w(25*m+90+1),w(iw)) --c --c --c Subselect from w(25*m+91 : 26*m+90) to obtain --c w(26*m+91 : 26*m+n+90). --c -- call idd_subselect(n,w(4),m,w(25*m+90+1),w(26*m+90+1)) --c --c --c Fourier transform w(26*m+91 : 26*m+n+90). --c -- call idd_sfft(l2,w(4+m+l),n,w(5+m+l+l2),w(26*m+90+1)) --c --c --c Copy the desired entries from w(26*m+91 : 26*m+n+90) --c to y. --c -- call idd_subselect(l,w(4+m),n,w(26*m+90+1),y) --c --c -- return -- end --c --c --c --c -- subroutine idd_pairsamps(n,l,ind,l2,ind2,marker) --c --c calculates the indices of the l2 pairs of integers --c to which the l individual integers from ind belong. --c The integers in ind may range from 1 to n. --c --c input: --c n -- upper bound on the integers in ind --c (the number 1 must be a lower bound); --c n must be even --c l -- length of ind --c ind -- integers selected from 1 to n --c --c output: --c l2 -- length of ind2 --c ind2 -- indices in the range from 1 to n/2 of the pairs --c of integers to which the entries of ind belong --c --c work: --c marker -- must be at least n/2 integer elements long --c --c _N.B._: n must be even. --c -- implicit none -- integer l,n,ind(l),ind2(l),marker(n/2),l2,k --c --c --c Unmark all pairs. --c -- do k = 1,n/2 -- marker(k) = 0 -- enddo ! k --c --c --c Mark the required pairs. --c -- do k = 1,l -- marker((ind(k)+1)/2) = marker((ind(k)+1)/2)+1 -- enddo ! k --c --c --c Record the required pairs in indpair. --c -- l2 = 0 --c -- do k = 1,n/2 --c -- if(marker(k) .ne. 0) then -- l2 = l2+1 -- ind2(l2) = k -- endif --c -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_permute(n,ind,x,y) --c --c copy the entries of x into y, rearranged according --c to the permutation specified by ind. --c --c input: --c n -- length of ind, x, and y --c ind -- permutation of n objects --c x -- vector to be permuted --c --c output: --c y -- permutation of x --c -- implicit none -- integer n,ind(n),k -- real*8 x(n),y(n) --c --c -- do k = 1,n -- y(k) = x(ind(k)) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_subselect(n,ind,m,x,y) --c --c copies into y the entries of x indicated by ind. --c --c input: --c n -- number of entries of x to copy into y --c ind -- indices of the entries in x to copy into y --c m -- length of x --c x -- vector whose entries are to be copied --c --c output: --c y -- collection of entries of x specified by ind --c -- implicit none -- integer n,ind(n),m,k -- real*8 x(m),y(n) --c --c -- do k = 1,n -- y(k) = x(ind(k)) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_frmi(m,n,w) --c --c initializes data for the routine idd_frm. --c --c input: --c m -- length of the vector to be transformed --c --c output: --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m --c w -- initialization array to be used by routine idd_frm --c --c --c glossary for the fully initialized w: --c --c w(1) = m --c w(2) = n --c w(3:2+m) stores a permutation of m objects --c w(3+m:2+m+n) stores a permutation of n objects --c w(3+m+n) = address in w of the initialization array --c for idd_random_transf --c w(4+m+n:int(w(3+m+n))-1) stores the initialization array --c for dfft --c w(int(w(3+m+n)):16*m+70) stores the initialization array --c for idd_random_transf --c --c --c _N.B._: n is an output of the present routine; --c this routine changes n. --c --c -- implicit none -- integer m,n,l,nsteps,keep,lw,ia -- real*8 w(17*m+70) --c --c --c Find the greatest integer less than or equal to m --c which is a power of two. --c -- call idd_poweroftwo(m,l,n) --c --c --c Store m and n in w. --c -- w(1) = m -- w(2) = n --c --c --c Store random permutations of m and n objects in w. --c -- call id_randperm(m,w(3)) -- call id_randperm(n,w(3+m)) --c --c --c Store the address within w of the idd_random_transf_init --c initialization data. --c -- ia = 4+m+n+2*n+15 -- w(3+m+n) = ia --c --c --c Store the initialization data for dfft in w. --c -- call dffti(n,w(4+m+n)) --c --c --c Store the initialization data for idd_random_transf_init in w. --c -- nsteps = 3 -- call idd_random_transf_init(nsteps,m,w(ia),keep) --c --c --c Calculate the total number of elements used in w. --c -- lw = 3+m+n+2*n+15 + 3*nsteps*m+2*m+m/4+50 --c -- if(16*m+70 .lt. lw) then -- call prinf('lw = *',lw,1) -- call prinf('16m+70 = *',16*m+70,1) -- stop -- endif --c --c -- return -- end --c --c --c --c -- subroutine idd_sfrmi(l,m,n,w) --c --c initializes data for the routine idd_sfrm. --c --c input: --c l -- length of the transformed (output) vector --c m -- length of the vector to be transformed --c --c output: --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m --c w -- initialization array to be used by routine idd_sfrm --c --c --c glossary for the fully initialized w: --c --c w(1) = m --c w(2) = n --c w(3) = l2 --c w(4:3+m) stores a permutation of m objects --c w(4+m:3+m+l) stores the indices of the l outputs which idd_sfft --c calculates --c w(4+m+l:3+m+l+l2) stores the indices of the l2 pairs of outputs --c which idd_sfft calculates --c w(4+m+l+l2) = address in w of the initialization array --c for idd_random_transf --c w(5+m+l+l2:int(w(4+m+l+l2))-1) stores the initialization array --c for idd_sfft --c w(int(w(4+m+l+l2)):25*m+90) stores the initialization array --c for idd_random_transf --c --c --c _N.B._: n is an output of the present routine; --c this routine changes n. --c --c -- implicit none -- integer l,m,n,idummy,nsteps,keep,lw,l2,ia -- real*8 w(27*m+90) --c --c --c Find the greatest integer less than or equal to m --c which is a power of two. --c -- call idd_poweroftwo(m,idummy,n) --c --c --c Store m and n in w. --c -- w(1) = m -- w(2) = n --c --c --c Store random permutations of m and n objects in w. --c -- call id_randperm(m,w(4)) -- call id_randperm(n,w(4+m)) --c --c --c Find the pairs of integers covering the integers in --c w(4+m : 3+m+(l+1)/2). --c -- call idd_pairsamps(n,l,w(4+m),l2,w(4+m+2*l),w(4+m+3*l)) -- w(3) = l2 -- call idd_copyints(l2,w(4+m+2*l),w(4+m+l)) --c --c --c Store the address within w of the idd_random_transf_init --c initialization data. --c -- ia = 5+m+l+l2+4*l2+30+8*n -- w(4+m+l+l2) = ia --c --c --c Store the initialization data for idd_sfft in w. --c -- call idd_sffti(l2,w(4+m+l),n,w(5+m+l+l2)) --c --c --c Store the initialization data for idd_random_transf_init in w. --c -- nsteps = 3 -- call idd_random_transf_init(nsteps,m,w(ia),keep) --c --c --c Calculate the total number of elements used in w. --c -- lw = 4+m+l+l2+4*l2+30+8*n + 3*nsteps*m+2*m+m/4+50 --c -- if(25*m+90 .lt. lw) then -- call prinf('lw = *',lw,1) -- call prinf('25m+90 = *',25*m+90,1) -- stop -- endif --c --c -- return -- end --c --c --c --c -- subroutine idd_copyints(n,ia,ib) --c --c copies ia into ib. --c --c input: --c n -- length of ia and ib --c ia -- array to be copied --c --c output: --c ib -- copy of ia --c -- implicit none -- integer n,ia(n),ib(n),k --c --c -- do k = 1,n -- ib(k) = ia(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_poweroftwo(m,l,n) --c --c computes l = floor(log_2(m)) and n = 2**l. --c --c input: --c m -- integer whose log_2 is to be taken --c --c output: --c l -- floor(log_2(m)) --c n -- 2**l --c -- implicit none -- integer l,m,n --c --c -- l = 0 -- n = 1 --c -- 1000 continue -- l = l+1 -- n = n*2 -- if(n .le. m) goto 1000 --c -- l = l-1 -- n = n/2 --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_house.f b/scipy/linalg/src/id_dist/src/idd_house.f -deleted file mode 100644 -index 715037117..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_house.f -+++ /dev/null -@@ -1,288 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idd_house calculates the vector and scalar --c needed to apply the Householder transformation reflecting --c a given vector into its first component. --c --c routine idd_houseapp applies a Householder matrix to a vector. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idd_houseapp(n,vn,u,ifrescal,scal,v) --c --c applies the Householder matrix --c identity_matrix - scal * vn * transpose(vn) --c to the vector u, yielding the vector v; --c --c scal = 2/(1 + vn(2)^2 + ... + vn(n)^2) --c when vn(2), ..., vn(n) don't all vanish; --c --c scal = 0 --c when vn(2), ..., vn(n) do all vanish --c (including when n = 1). --c --c input: --c n -- size of vn, u, and v, though the indexing on vn goes --c from 2 to n --c vn -- components 2 to n of the Householder vector vn; --c vn(1) is assumed to be 1 --c u -- vector to be transformed --c ifrescal -- set to 1 to recompute scal from vn(2), ..., vn(n); --c set to 0 to use scal as input --c scal -- see the entry for ifrescal in the decription --c of the input --c --c output: --c scal -- see the entry for ifrescal in the decription --c of the input --c v -- result of applying the Householder matrix to u; --c it's O.K. to have v be the same as u --c in order to apply the matrix to the vector in place --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- save -- integer n,k,ifrescal -- real*8 vn(2:*),scal,u(n),v(n),fact,sum --c --c --c Get out of this routine if n = 1. --c -- if(n .eq. 1) then -- v(1) = u(1) -- return -- endif --c --c -- if(ifrescal .eq. 1) then --c --c --c Calculate (vn(2))^2 + ... + (vn(n))^2. --c -- sum = 0 -- do k = 2,n -- sum = sum+vn(k)**2 -- enddo ! k --c --c --c Calculate scal. --c -- if(sum .eq. 0) scal = 0 -- if(sum .ne. 0) scal = 2/(1+sum) --c --c -- endif --c --c --c Calculate fact = scal * transpose(vn) * u. --c -- fact = u(1) --c -- do k = 2,n -- fact = fact+vn(k)*u(k) -- enddo ! k --c -- fact = fact*scal --c --c --c Subtract fact*vn from u, yielding v. --c -- v(1) = u(1) - fact --c -- do k = 2,n -- v(k) = u(k) - fact*vn(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_house(n,x,rss,vn,scal) --c --c constructs the vector vn with vn(1) = 1 --c and the scalar scal such that --c H := identity_matrix - scal * vn * transpose(vn) is orthogonal --c and Hx = +/- e_1 * the root-sum-square of the entries of x --c (H is the Householder matrix corresponding to x). --c --c input: --c n -- size of x and vn, though the indexing on vn goes --c from 2 to n --c x -- vector to reflect into its first component --c --c output: --c rss -- first entry of the vector resulting from the application --c of the Householder matrix to x; --c its absolute value is the root-sum-square --c of the entries of x --c vn -- entries 2 to n of the Householder vector vn; --c vn(1) is assumed to be 1 --c scal -- scalar multiplying vn * transpose(vn); --c --c scal = 2/(1 + vn(2)^2 + ... + vn(n)^2) --c when vn(2), ..., vn(n) don't all vanish; --c --c scal = 0 --c when vn(2), ..., vn(n) do all vanish --c (including when n = 1) --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- save -- integer n,k -- real*8 x(n),rss,sum,v1,scal,vn(2:*),x1 --c --c -- x1 = x(1) --c --c --c Get out of this routine if n = 1. --c -- if(n .eq. 1) then -- rss = x1 -- scal = 0 -- return -- endif --c --c --c Calculate (x(2))^2 + ... (x(n))^2 --c and the root-sum-square value of the entries in x. --c --c -- sum = 0 -- do k = 2,n -- sum = sum+x(k)**2 -- enddo ! k --c --c --c Get out of this routine if sum = 0; --c flag this case as such by setting v(2), ..., v(n) all to 0. --c -- if(sum .eq. 0) then --c -- rss = x1 -- do k = 2,n -- vn(k) = 0 -- enddo ! k -- scal = 0 --c -- return --c -- endif --c --c -- rss = x1**2 + sum -- rss = sqrt(rss) --c --c --c Determine the first component v1 --c of the unnormalized Householder vector --c v = x - rss * (1 0 0 ... 0 0)^T. --c --c If x1 <= 0, then form x1-rss directly, --c since that expression cannot involve any cancellation. --c -- if(x1 .le. 0) v1 = x1-rss --c --c If x1 > 0, then use the fact that --c x1-rss = -sum / (x1+rss), --c in order to avoid potential cancellation. --c -- if(x1 .gt. 0) v1 = -sum / (x1+rss) --c --c --c Compute the vector vn and the scalar scal such that vn(1) = 1 --c in the Householder transformation --c identity_matrix - scal * vn * transpose(vn). --c -- do k = 2,n -- vn(k) = x(k)/v1 -- enddo ! k --c --c scal = 2 --c / ( vn(1)^2 + vn(2)^2 + ... + vn(n)^2 ) --c --c = 2 --c / ( 1 + vn(2)^2 + ... + vn(n)^2 ) --c --c = 2*v(1)^2 --c / ( v(1)^2 + (v(1)*vn(2))^2 + ... + (v(1)*vn(n))^2 ) --c --c = 2*v(1)^2 --c / ( v(1)^2 + (v(2)^2 + ... + v(n)^2) ) --c -- scal = 2*v1**2 / (v1**2+sum) --c --c -- return -- end --c --c --c --c -- subroutine idd_housemat(n,vn,scal,h) --c --c fills h with the Householder matrix --c identity_matrix - scal * vn * transpose(vn). --c --c input: --c n -- size of vn and h, though the indexing of vn goes --c from 2 to n --c vn -- entries 2 to n of the vector vn; --c vn(1) is assumed to be 1 --c scal -- scalar multiplying vn * transpose(vn) --c --c output: --c h -- identity_matrix - scal * vn * transpose(vn) --c -- implicit none -- save -- integer n,j,k -- real*8 vn(2:*),h(n,n),scal,factor1,factor2 --c --c --c Fill h with the identity matrix. --c -- do j = 1,n -- do k = 1,n --c -- if(j .eq. k) h(k,j) = 1 -- if(j .ne. k) h(k,j) = 0 --c -- enddo ! k -- enddo ! j --c --c --c Subtract from h the matrix scal*vn*transpose(vn). --c -- do j = 1,n -- do k = 1,n --c -- if(j .eq. 1) factor1 = 1 -- if(j .ne. 1) factor1 = vn(j) --c -- if(k .eq. 1) factor2 = 1 -- if(k .ne. 1) factor2 = vn(k) --c -- h(k,j) = h(k,j) - scal*factor1*factor2 --c -- enddo ! k -- enddo ! j --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_id.f b/scipy/linalg/src/id_dist/src/idd_id.f -deleted file mode 100644 -index 640ff455b..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_id.f -+++ /dev/null -@@ -1,560 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddp_id computes the ID of a matrix, --c to a specified precision. --c --c routine iddr_id computes the ID of a matrix, --c to a specified rank. --c --c routine idd_reconid reconstructs a matrix from its ID. --c --c routine idd_copycols collects together selected columns --c of a matrix. --c --c routine idd_getcols collects together selected columns --c of a matrix specified by a routine for applying the matrix --c to arbitrary vectors. --c --c routine idd_reconint constructs p in the ID a = b p, --c where the columns of b are a subset of the columns of a, --c and p is the projection coefficient matrix, --c given list, krank, and proj output by routines iddr_id --c or iddp_id. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddp_id(eps,m,n,a,krank,list,rnorms) --c --c computes the ID of a, i.e., lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon dimensioned epsilon(m,n-krank) --c such that the greatest singular value of epsilon --c <= the greatest singular value of a * eps. --c The present routine stores the krank x (n-krank) matrix proj --c in the memory initially occupied by a. --c --c input: --c eps -- relative precision of the resulting ID --c m -- first dimension of a --c n -- second dimension of a, as well as the dimension required --c of list --c a -- matrix to be ID'd --c --c output: --c a -- the first krank*(n-krank) elements of a constitute --c the krank x (n-krank) interpolation matrix proj --c krank -- numerical rank --c list -- list of the indices of the krank columns of a --c through which the other columns of a are expressed; --c also, list describes the permutation of proj --c required to reconstruct a as indicated in (*) above --c rnorms -- absolute values of the entries on the diagonal --c of the triangular matrix used to compute the ID --c (these may be used to check the stability of the ID) --c --c _N.B._: This routine changes a. --c --c reference: --c Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of --c low-rank matrices," SIAM Journal on Scientific Computing, --c 26 (4): 1389-1404, 2005. --c -- implicit none -- integer m,n,krank,k,list(n),iswap -- real*8 a(m,n),eps,rnorms(n) --c --c --c QR decompose a. --c -- call iddp_qrpiv(eps,m,n,a,krank,list,rnorms) --c --c --c Build the list of columns chosen in a --c by multiplying together the permutations in list, --c with the permutation swapping 1 and list(1) taken rightmost --c in the product, that swapping 2 and list(2) taken next --c rightmost, ..., that swapping krank and list(krank) taken --c leftmost. --c -- do k = 1,n -- rnorms(k) = k -- enddo ! k --c -- if(krank .gt. 0) then -- do k = 1,krank --c --c Swap rnorms(k) and rnorms(list(k)). --c -- iswap = rnorms(k) -- rnorms(k) = rnorms(list(k)) -- rnorms(list(k)) = iswap --c -- enddo ! k -- endif --c -- do k = 1,n -- list(k) = rnorms(k) -- enddo ! k --c --c --c Fill rnorms for the output. --c -- if(krank .gt. 0) then --c -- do k = 1,krank -- rnorms(k) = a(k,k) -- enddo ! k --c -- endif --c --c --c Backsolve for proj, storing it at the beginning of a. --c -- if(krank .gt. 0) then -- call idd_lssolve(m,n,a,krank) -- endif --c --c -- return -- end --c --c --c --c -- subroutine iddr_id(m,n,a,krank,list,rnorms) --c --c computes the ID of a, i.e., lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon, dimensioned epsilon(m,n-krank), --c whose norm is (hopefully) minimized by the pivoting procedure. --c The present routine stores the krank x (n-krank) matrix proj --c in the memory initially occupied by a. --c --c input: --c m -- first dimension of a --c n -- second dimension of a, as well as the dimension required --c of list --c a -- matrix to be ID'd --c krank -- desired rank of the output matrix --c (please note that if krank > m or krank > n, --c then the rank of the output matrix will be --c less than krank) --c --c output: --c a -- the first krank*(n-krank) elements of a constitute --c the krank x (n-krank) interpolation matrix proj --c list -- list of the indices of the krank columns of a --c through which the other columns of a are expressed; --c also, list describes the permutation of proj --c required to reconstruct a as indicated in (*) above --c rnorms -- absolute values of the entries on the diagonal --c of the triangular matrix used to compute the ID --c (these may be used to check the stability of the ID) --c --c _N.B._: This routine changes a. --c --c reference: --c Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of --c low-rank matrices," SIAM Journal on Scientific Computing, --c 26 (4): 1389-1404, 2005. --c -- implicit none -- integer m,n,krank,j,k,list(n),iswap -- real*8 a(m,n),rnorms(n),ss --c --c --c QR decompose a. --c -- call iddr_qrpiv(m,n,a,krank,list,rnorms) --c --c --c Build the list of columns chosen in a --c by multiplying together the permutations in list, --c with the permutation swapping 1 and list(1) taken rightmost --c in the product, that swapping 2 and list(2) taken next --c rightmost, ..., that swapping krank and list(krank) taken --c leftmost. --c -- do k = 1,n -- rnorms(k) = k -- enddo ! k --c -- if(krank .gt. 0) then -- do k = 1,krank --c --c Swap rnorms(k) and rnorms(list(k)). --c -- iswap = rnorms(k) -- rnorms(k) = rnorms(list(k)) -- rnorms(list(k)) = iswap --c -- enddo ! k -- endif --c -- do k = 1,n -- list(k) = rnorms(k) -- enddo ! k --c --c --c Fill rnorms for the output. --c -- ss = 0 --c -- do k = 1,krank -- rnorms(k) = a(k,k) -- ss = ss+rnorms(k)**2 -- enddo ! k --c --c --c Backsolve for proj, storing it at the beginning of a. --c -- if(krank .gt. 0 .and. ss .gt. 0) then -- call idd_lssolve(m,n,a,krank) -- endif --c -- if(ss .eq. 0) then --c -- do k = 1,n -- do j = 1,m --c -- a(j,k) = 0 --c -- enddo ! j -- enddo ! k --c -- endif --c --c -- return -- end --c --c --c --c -- subroutine idd_reconid(m,krank,col,n,list,proj,approx) --c --c reconstructs the matrix that the routine iddp_id --c or iddr_id has decomposed, using the columns col --c of the reconstructed matrix whose indices are listed in list, --c in addition to the interpolation matrix proj. --c --c input: --c m -- first dimension of cols and approx --c krank -- first dimension of cols and proj; also, --c n-krank is the second dimension of proj --c col -- columns of the matrix to be reconstructed --c n -- second dimension of approx; also, --c n-krank is the second dimension of proj --c list(k) -- index of col(1:m,k) in the reconstructed matrix --c when k <= krank; in general, list describes --c the permutation required for reconstruction --c via cols and proj --c proj -- interpolation matrix --c --c output: --c approx -- reconstructed matrix --c -- implicit none -- integer m,n,krank,j,k,l,list(n) -- real*8 col(m,krank),proj(krank,n-krank),approx(m,n) --c --c -- do j = 1,m -- do k = 1,n --c -- approx(j,list(k)) = 0 --c --c Add in the contributions due to the identity matrix. --c -- if(k .le. krank) then -- approx(j,list(k)) = approx(j,list(k)) + col(j,k) -- endif --c --c Add in the contributions due to proj. --c -- if(k .gt. krank) then -- if(krank .gt. 0) then --c -- do l = 1,krank -- approx(j,list(k)) = approx(j,list(k)) -- 1 + col(j,l)*proj(l,k-krank) -- enddo ! l --c -- endif -- endif --c -- enddo ! k -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idd_lssolve(m,n,a,krank) --c --c backsolves for proj satisfying R_11 proj ~ R_12, --c where R_11 = a(1:krank,1:krank) --c and R_12 = a(1:krank,krank+1:n). --c This routine overwrites the beginning of a with proj. --c --c input: --c m -- first dimension of a --c n -- second dimension of a; also, --c n-krank is the second dimension of proj --c a -- trapezoidal input matrix --c krank -- first dimension of proj; also, --c n-krank is the second dimension of proj --c --c output: --c a -- the first krank*(n-krank) elements of a constitute --c the krank x (n-krank) matrix proj --c -- implicit none -- integer m,n,krank,j,k,l -- real*8 a(m,n),sum --c --c --c Overwrite a(1:krank,krank+1:n) with proj. --c -- do k = 1,n-krank -- do j = krank,1,-1 --c -- sum = 0 --c -- do l = j+1,krank -- sum = sum+a(j,l)*a(l,krank+k) -- enddo ! l --c -- a(j,krank+k) = a(j,krank+k)-sum --c --c Make sure that the entry in proj won't be too big; --c set the entry to 0 when roundoff would make it too big --c (in which case a(j,j) is so small that the contribution --c from this entry in proj to the overall matrix approximation --c is supposed to be negligible). --c -- if(abs(a(j,krank+k)) .lt. 2**20*abs(a(j,j))) then -- a(j,krank+k) = a(j,krank+k)/a(j,j) -- else -- a(j,krank+k) = 0 -- endif --c -- enddo ! j -- enddo ! k --c --c --c Move proj from a(1:krank,krank+1:n) to the beginning of a. --c -- call idd_moverup(m,n,krank,a) --c --c -- return -- end --c --c --c --c -- subroutine idd_moverup(m,n,krank,a) --c --c moves the krank x (n-krank) matrix in a(1:krank,krank+1:n), --c where a is initially dimensioned m x n, to the beginning of a. --c (This is not the most natural way to code the move, --c but one of my usually well-behaved compilers chokes --c on more natural ways.) --c --c input: --c m -- initial first dimension of a --c n -- initial second dimension of a --c krank -- number of rows to move --c a -- m x n matrix whose krank x (n-krank) block --c a(1:krank,krank+1:n) is to be moved --c --c output: --c a -- array starting with the moved krank x (n-krank) block --c -- implicit none -- integer m,n,krank,j,k -- real*8 a(m*n) --c --c -- do k = 1,n-krank -- do j = 1,krank -- a(j+krank*(k-1)) = a(j+m*(krank+k-1)) -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list, -- 1 col,x) --c --c collects together the columns of the matrix a indexed by list --c into the matrix col, where routine matvec applies a --c to an arbitrary vector. --c --c input: --c m -- first dimension of a --c n -- second dimension of a --c matvec -- routine which applies a to an arbitrary vector; --c this routine must have a calling sequence of the form --c --c matvec(m,x,n,y,p1,p2,p3,p4) --c --c where m is the length of x, --c x is the vector to which the matrix is to be applied, --c n is the length of y, --c y is the product of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c krank -- number of columns to be extracted --c list -- indices of the columns to be extracted --c --c output: --c col -- columns of a indexed by list --c --c work: --c x -- must be at least n real*8 elements long --c -- implicit none -- integer m,n,krank,list(krank),j,k -- real*8 col(m,krank),x(n),p1,p2,p3,p4 -- external matvec --c --c -- do j = 1,krank --c -- do k = 1,n -- x(k) = 0 -- enddo ! k --c -- x(list(j)) = 1 --c -- call matvec(n,x,m,col(1,j),p1,p2,p3,p4) --c -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idd_reconint(n,list,krank,proj,p) --c --c constructs p in the ID a = b p, --c where the columns of b are a subset of the columns of a, --c and p is the projection coefficient matrix, --c given list, krank, and proj output --c by routines iddp_id or iddr_id. --c --c input: --c n -- part of the second dimension of proj and p --c list -- list of columns retained from the original matrix --c in the ID --c krank -- rank of the ID --c proj -- matrix of projection coefficients in the ID --c --c output: --c p -- projection matrix in the ID --c -- implicit none -- integer n,krank,list(n),j,k -- real*8 proj(krank,n-krank),p(krank,n) --c --c -- do k = 1,krank -- do j = 1,n --c -- if(j .le. krank) then -- if(j .eq. k) p(k,list(j)) = 1 -- if(j .ne. k) p(k,list(j)) = 0 -- endif --c -- if(j .gt. krank) then -- p(k,list(j)) = proj(k,j-krank) -- endif --c -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_copycols(m,n,a,krank,list,col) --c --c collects together the columns of the matrix a indexed by list --c into the matrix col. --c --c input: --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix whose columns are to be extracted --c krank -- number of columns to be extracted --c list -- indices of the columns to be extracted --c --c output: --c col -- columns of a indexed by list --c -- implicit none -- integer m,n,krank,list(krank),j,k -- real*8 a(m,n),col(m,krank) --c --c -- do k = 1,krank -- do j = 1,m --c -- col(j,k) = a(j,list(k)) --c -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_id2svd.f b/scipy/linalg/src/id_dist/src/idd_id2svd.f -deleted file mode 100644 -index 42e1f23cd..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_id2svd.f -+++ /dev/null -@@ -1,384 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idd_id2svd converts an approximation to a matrix --c in the form of an ID to an approximation in the form of an SVD. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idd_id2svd(m,krank,b,n,list,proj,u,v,s,ier,w) --c --c converts an approximation to a matrix in the form of an ID --c to an approximation in the form of an SVD. --c --c input: --c m -- first dimension of b --c krank -- rank of the ID --c b -- columns of the original matrix in the ID --c list -- list of columns chosen from the original matrix --c in the ID --c n -- length of list and part of the second dimension of proj --c proj -- projection coefficients in the ID --c --c output: --c u -- left singular vectors --c v -- right singular vectors --c s -- singular values --c ier -- 0 when the routine terminates successfully; --c nonzero otherwise --c --c work: --c w -- must be at least (krank+1)*(m+3*n)+26*krank**2 real*8 --c elements long --c --c _N.B._: This routine destroys b. --c -- implicit none -- integer m,krank,n,list(n),iwork,lwork,ip,lp,it,lt,ir,lr, -- 1 ir2,lr2,ir3,lr3,iind,lind,iindt,lindt,lw,ier -- real*8 b(m,krank),proj(krank,n-krank),u(m,krank),v(n,krank), -- 1 w((krank+1)*(m+3*n)+26*krank**2),s(krank) --c --c -- lw = 0 --c -- iwork = lw+1 -- lwork = 25*krank**2 -- lw = lw+lwork --c -- ip = lw+1 -- lp = krank*n -- lw = lw+lp --c -- it = lw+1 -- lt = n*krank -- lw = lw+lt --c -- ir = lw+1 -- lr = krank*n -- lw = lw+lr --c -- ir2 = lw+1 -- lr2 = krank*m -- lw = lw+lr2 --c -- ir3 = lw+1 -- lr3 = krank*krank -- lw = lw+lr3 --c -- iind = lw+1 -- lind = n/2+1 -- lw = lw+1 --c -- iindt = lw+1 -- lindt = m/2+1 -- lw = lw+1 --c --c -- call idd_id2svd0(m,krank,b,n,list,proj,u,v,s,ier, -- 1 w(iwork),w(ip),w(it),w(ir),w(ir2),w(ir3), -- 2 w(iind),w(iindt)) --c --c -- return -- end --c --c --c --c -- subroutine idd_id2svd0(m,krank,b,n,list,proj,u,v,s,ier, -- 1 work,p,t,r,r2,r3,ind,indt) --c --c routine idd_id2svd serves as a memory wrapper --c for the present routine (please see routine idd_id2svd --c for further documentation). --c -- implicit none --c -- character*1 jobz -- integer m,n,krank,list(n),ind(n),indt(m),iftranspose, -- 1 lwork,ldu,ldvt,ldr,info,j,k,ier -- real*8 b(m,krank),proj(krank,n-krank),p(krank,n), -- 1 r(krank,n),r2(krank,m),t(n,krank),r3(krank,krank), -- 2 u(m,krank),v(n,krank),s(krank),work(25*krank**2) --c --c --c -- ier = 0 --c --c --c --c Construct the projection matrix p from the ID. --c -- call idd_reconint(n,list,krank,proj,p) --c --c --c --c Compute a pivoted QR decomposition of b. --c -- call iddr_qrpiv(m,krank,b,krank,ind,r) --c --c --c Extract r from the QR decomposition. --c -- call idd_rinqr(m,krank,b,krank,r) --c --c --c Rearrange r according to ind. --c -- call idd_rearr(krank,ind,krank,krank,r) --c --c --c --c Transpose p to obtain t. --c -- call idd_mattrans(krank,n,p,t) --c --c --c Compute a pivoted QR decomposition of t. --c -- call iddr_qrpiv(n,krank,t,krank,indt,r2) --c --c --c Extract r2 from the QR decomposition. --c -- call idd_rinqr(n,krank,t,krank,r2) --c --c --c Rearrange r2 according to indt. --c -- call idd_rearr(krank,indt,krank,krank,r2) --c --c --c --c Multiply r and r2^T to obtain r3. --c -- call idd_matmultt(krank,krank,r,krank,r2,r3) --c --c --c --c Use LAPACK to SVD r3. --c -- jobz = 'S' -- ldr = krank -- lwork = 25*krank**2-krank**2-4*krank -- ldu = krank -- ldvt = krank --c -- call dgesdd(jobz,krank,krank,r3,ldr,s,work,ldu,r,ldvt, -- 1 work(krank**2+4*krank+1),lwork, -- 2 work(krank**2+1),info) --c -- if(info .ne. 0) then -- ier = info -- return -- endif --c --c --c --c Multiply the u from r3 from the left by the q from b --c to obtain the u for a. --c -- do k = 1,krank --c -- do j = 1,krank -- u(j,k) = work(j+krank*(k-1)) -- enddo ! j --c -- do j = krank+1,m -- u(j,k) = 0 -- enddo ! j --c -- enddo ! k --c -- iftranspose = 0 -- call idd_qmatmat(iftranspose,m,krank,b,krank,krank,u,r2) --c --c --c --c Transpose r to obtain r2. --c -- call idd_mattrans(krank,krank,r,r2) --c --c --c Multiply the v from r3 from the left by the q from p^T --c to obtain the v for a. --c -- do k = 1,krank --c -- do j = 1,krank -- v(j,k) = r2(j,k) -- enddo ! j --c -- do j = krank+1,n -- v(j,k) = 0 -- enddo ! j --c -- enddo ! k --c -- iftranspose = 0 -- call idd_qmatmat(iftranspose,n,krank,t,krank,krank,v,r2) --c --c -- return -- end --c --c --c --c -- subroutine idd_mattrans(m,n,a,at) --c --c transposes a to obtain at. --c --c input: --c m -- first dimension of a, and second dimension of at --c n -- second dimension of a, and first dimension of at --c a -- matrix to be transposed --c --c output: --c at -- transpose of a --c -- implicit none -- integer m,n,j,k -- real*8 a(m,n),at(n,m) --c --c -- do k = 1,n -- do j = 1,m -- at(k,j) = a(j,k) -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_matmultt(l,m,a,n,b,c) --c --c multiplies a and b^T to obtain c. --c --c input: --c l -- first dimension of a and c --c m -- second dimension of a and b --c a -- leftmost matrix in the product c = a b^T --c n -- first dimension of b and second dimension of c --c b -- rightmost matrix in the product c = a b^T --c --c output: --c c -- product of a and b^T --c -- implicit none -- integer l,m,n,i,j,k -- real*8 a(l,m),b(n,m),c(l,n),sum --c --c -- do i = 1,l -- do k = 1,n --c -- sum = 0 --c -- do j = 1,m -- sum = sum+a(i,j)*b(k,j) -- enddo ! j --c -- c(i,k) = sum --c -- enddo ! k -- enddo ! i --c --c -- return -- end --c --c --c --c -- subroutine idd_rearr(krank,ind,m,n,a) --c --c rearranges a according to ind obtained --c from routines iddr_qrpiv or iddp_qrpiv, --c assuming that a = q r, where q and r are from iddr_qrpiv --c or iddp_qrpiv. --c --c input: --c krank -- rank obtained from routine iddp_qrpiv, --c or provided to routine iddr_qrpiv --c ind -- indexing array obtained from routine iddr_qrpiv --c or iddp_qrpiv --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix to be rearranged --c --c output: --c a -- rearranged matrix --c -- implicit none -- integer k,krank,m,n,j,ind(krank) -- real*8 rswap,a(m,n) --c --c -- do k = krank,1,-1 -- do j = 1,m --c -- rswap = a(j,k) -- a(j,k) = a(j,ind(k)) -- a(j,ind(k)) = rswap --c -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_rinqr(m,n,a,krank,r) --c --c extracts R in the QR decomposition specified by the output a --c of the routine iddr_qrpiv or iddp_qrpiv. --c --c input: --c m -- first dimension of a --c n -- second dimension of a and r --c a -- output of routine iddr_qrpiv or iddp_qrpiv --c krank -- rank output by routine iddp_qrpiv (or specified --c to routine iddr_qrpiv) --c --c output: --c r -- triangular factor in the QR decomposition specified --c by the output a of the routine iddr_qrpiv or iddp_qrpiv --c -- implicit none -- integer m,n,j,k,krank -- real*8 a(m,n),r(krank,n) --c --c --c Copy a into r and zero out the appropriate --c Householder vectors that are stored in one triangle of a. --c -- do k = 1,n -- do j = 1,krank -- r(j,k) = a(j,k) -- enddo ! j -- enddo ! k --c -- do k = 1,n -- if(k .lt. krank) then -- do j = k+1,krank -- r(j,k) = 0 -- enddo ! j -- endif -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_qrpiv.f b/scipy/linalg/src/id_dist/src/idd_qrpiv.f -deleted file mode 100644 -index b1dd88e15..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_qrpiv.f -+++ /dev/null -@@ -1,893 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddp_qrpiv computes the pivoted QR decomposition --c of a matrix via Householder transformations, --c stopping at a specified precision of the decomposition. --c --c routine iddr_qrpiv computes the pivoted QR decomposition --c of a matrix via Householder transformations, --c stopping at a specified rank of the decomposition. --c --c routine idd_qmatvec applies to a single vector --c the Q matrix (or its transpose) in the QR decomposition --c of a matrix, as described by the output of iddp_qrpiv --c or iddr_qrpiv. If you're concerned about efficiency --c and want to apply Q (or its transpose) to multiple vectors, --c use idd_qmatmat instead. --c --c routine idd_qmatmat applies --c to multiple vectors collected together --c as a matrix the Q matrix (or its transpose) --c in the QR decomposition of a matrix, as described --c by the output of iddp_qrpiv or iddr_qrpiv. If you don't want --c to provide a work array and want to apply Q (or its transpose) --c to a single vector, use idd_qmatvec instead. --c --c routine idd_qinqr reconstructs the Q matrix --c in a QR decomposition from the data generated --c by iddp_qrpiv or iddr_qrpiv. --c --c routine idd_permmult multiplies together a bunch --c of permutations. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- -- subroutine idd_permmult(m,ind,n,indprod) --c --c multiplies together the series of permutations in ind. --c --c input: --c m -- length of ind --c ind(k) -- number of the slot with which to swap --c the k^th slot --c n -- length of indprod and indprodinv --c --c output: --c indprod -- product of the permutations in ind, --c with the permutation swapping 1 and ind(1) --c taken leftmost in the product, --c that swapping 2 and ind(2) taken next leftmost, --c ..., that swapping krank and ind(krank) --c taken rightmost; indprod(k) is the number --c of the slot with which to swap the k^th slot --c in the product permutation --c -- implicit none -- integer m,n,ind(m),indprod(n),k,iswap --c --c -- do k = 1,n -- indprod(k) = k -- enddo ! k --c -- do k = m,1,-1 --c --c Swap indprod(k) and indprod(ind(k)). --c -- iswap = indprod(k) -- indprod(k) = indprod(ind(k)) -- indprod(ind(k)) = iswap --c -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_qinqr(m,n,a,krank,q) --c --c constructs the matrix q from iddp_qrpiv or iddr_qrpiv --c (see the routine iddp_qrpiv or iddr_qrpiv --c for more information). --c --c input: --c m -- first dimension of a; also, right now, q is m x m --c n -- second dimension of a --c a -- matrix output by iddp_qrpiv or iddr_qrpiv --c (and denoted the same there) --c krank -- numerical rank output by iddp_qrpiv or iddr_qrpiv --c (and denoted the same there) --c --c output: --c q -- orthogonal matrix implicitly specified by the data in a --c from iddp_qrpiv or iddr_qrpiv --c --c Note: --c Right now, this routine simply multiplies --c one after another the krank Householder matrices --c in the full QR decomposition of a, --c in order to obtain the complete m x m Q factor in the QR. --c This routine should instead use the following --c (more elaborate but more efficient) scheme --c to construct a q dimensioned q(krank,m); this scheme --c was introduced by Robert Schreiber and Charles Van Loan --c in "A Storage-Efficient _WY_ Representation --c for Products of Householder Transformations," --c _SIAM Journal on Scientific and Statistical Computing_, --c Vol. 10, No. 1, pp. 53-57, January, 1989: --c --c Theorem 1. Suppose that Q = _1_ + YTY^T is --c an m x m orthogonal real matrix, --c where Y is an m x k real matrix --c and T is a k x k upper triangular real matrix. --c Suppose also that P = _1_ - 2 v v^T is --c a real Householder matrix and Q_+ = QP, --c where v is an m x 1 real vector, --c normalized so that v^T v = 1. --c Then, Q_+ = _1_ + Y_+ T_+ Y_+^T, --c where Y_+ = (Y v) is the m x (k+1) matrix --c formed by adjoining v to the right of Y, --c ( T z ) --c and T_+ = ( ) is --c ( 0 -2 ) --c the (k+1) x (k+1) upper triangular matrix --c formed by adjoining z to the right of T --c and the vector (0 ... 0 -2) with k zeroes below (T z), --c where z = -2 T Y^T v. --c --c Now, suppose that A is a (rank-deficient) matrix --c whose complete QR decomposition has --c the blockwise partioned form --c ( Q_11 Q_12 ) ( R_11 R_12 ) ( Q_11 ) --c A = ( ) ( ) = ( ) (R_11 R_12). --c ( Q_21 Q_22 ) ( 0 0 ) ( Q_21 ) --c Then, the only blocks of the orthogonal factor --c in the above QR decomposition of A that matter are --c ( Q_11 ) --c Q_11 and Q_21, _i.e._, only the block of columns ( ) --c ( Q_21 ) --c interests us. --c Suppose in addition that Q_11 is a k x k matrix, --c Q_21 is an (m-k) x k matrix, and that --c ( Q_11 Q_12 ) --c ( ) = _1_ + YTY^T, as in Theorem 1 above. --c ( Q_21 Q_22 ) --c Then, Q_11 = _1_ + Y_1 T Y_1^T --c and Q_21 = Y_2 T Y_1^T, --c where Y_1 is the k x k matrix and Y_2 is the (m-k) x k matrix --c ( Y_1 ) --c so that Y = ( ). --c ( Y_2 ) --c --c So, you can calculate T and Y via the above recursions, --c and then use these to compute the desired Q_11 and Q_21. --c --c -- implicit none -- integer m,n,krank,j,k,mm,ifrescal -- real*8 a(m,n),q(m,m),scal --c --c --c Zero all of the entries of q. --c -- do k = 1,m -- do j = 1,m -- q(j,k) = 0 -- enddo ! j -- enddo ! k --c --c --c Place 1's along the diagonal of q. --c -- do k = 1,m -- q(k,k) = 1 -- enddo ! k --c --c --c Apply the krank Householder transformations stored in a. --c -- do k = krank,1,-1 -- do j = k,m -- mm = m-k+1 -- ifrescal = 1 -- if(k .lt. m) -- 1 call idd_houseapp(mm,a(k+1,k),q(k,j),ifrescal,scal,q(k,j)) -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_qmatvec(iftranspose,m,n,a,krank,v) --c --c applies to a single vector the Q matrix (or its transpose) --c which the routine iddp_qrpiv or iddr_qrpiv has stored --c in a triangle of the matrix it produces (stored, incidentally, --c as data for applying a bunch of Householder reflections). --c Use the routine qmatmat to apply the Q matrix --c (or its transpose) --c to a bunch of vectors collected together as a matrix, --c if you're concerned about efficiency. --c --c input: --c iftranspose -- set to 0 for applying Q; --c set to 1 for applying the transpose of Q --c m -- first dimension of a and length of v --c n -- second dimension of a --c a -- data describing the qr decomposition of a matrix, --c as produced by iddp_qrpiv or iddr_qrpiv --c krank -- numerical rank --c v -- vector to which Q (or its transpose) is to be applied --c --c output: --c v -- vector to which Q (or its transpose) has been applied --c -- implicit none -- save -- integer m,n,krank,k,ifrescal,mm,iftranspose -- real*8 a(m,n),v(m),scal --c --c -- ifrescal = 1 --c --c -- if(iftranspose .eq. 0) then --c -- do k = krank,1,-1 -- mm = m-k+1 -- if(k .lt. m) -- 1 call idd_houseapp(mm,a(k+1,k),v(k),ifrescal,scal,v(k)) -- enddo ! k --c -- endif --c --c -- if(iftranspose .eq. 1) then --c -- do k = 1,krank -- mm = m-k+1 -- if(k .lt. m) -- 1 call idd_houseapp(mm,a(k+1,k),v(k),ifrescal,scal,v(k)) -- enddo ! k --c -- endif --c --c -- return -- end --c --c --c --c -- subroutine idd_qmatmat(iftranspose,m,n,a,krank,l,b,work) --c --c applies to a bunch of vectors collected together as a matrix --c the Q matrix (or its transpose) which the routine iddp_qrpiv or --c iddr_qrpiv has stored in a triangle of the matrix it produces --c (stored, incidentally, as data for applying a bunch --c of Householder reflections). --c Use the routine qmatvec to apply the Q matrix --c (or its transpose) --c to a single vector, if you'd rather not provide a work array. --c --c input: --c iftranspose -- set to 0 for applying Q; --c set to 1 for applying the transpose of Q --c m -- first dimension of both a and b --c n -- second dimension of a --c a -- data describing the qr decomposition of a matrix, --c as produced by iddp_qrpiv or iddr_qrpiv --c krank -- numerical rank --c l -- second dimension of b --c b -- matrix to which Q (or its transpose) is to be applied --c --c output: --c b -- matrix to which Q (or its transpose) has been applied --c --c work: --c work -- must be at least krank real*8 elements long --c -- implicit none -- save -- integer l,m,n,krank,j,k,ifrescal,mm,iftranspose -- real*8 a(m,n),b(m,l),work(krank) --c --c -- if(iftranspose .eq. 0) then --c --c --c Handle the first iteration, j = 1, --c calculating all scals (ifrescal = 1). --c -- ifrescal = 1 --c -- j = 1 --c -- do k = krank,1,-1 -- if(k .lt. m) then -- mm = m-k+1 -- call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c --c -- if(l .gt. 1) then --c --c Handle the other iterations, j > 1, --c using the scals just computed (ifrescal = 0). --c -- ifrescal = 0 --c -- do j = 2,l --c -- do k = krank,1,-1 -- if(k .lt. m) then -- mm = m-k+1 -- call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c -- enddo ! j --c -- endif ! j .gt. 1 --c --c -- endif ! iftranspose .eq. 0 --c --c -- if(iftranspose .eq. 1) then --c --c --c Handle the first iteration, j = 1, --c calculating all scals (ifrescal = 1). --c -- ifrescal = 1 --c -- j = 1 --c -- do k = 1,krank -- if(k .lt. m) then -- mm = m-k+1 -- call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c --c -- if(l .gt. 1) then --c --c Handle the other iterations, j > 1, --c using the scals just computed (ifrescal = 0). --c -- ifrescal = 0 --c -- do j = 2,l --c -- do k = 1,krank -- if(k .lt. m) then -- mm = m-k+1 -- call idd_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c -- enddo ! j --c -- endif ! j .gt. 1 --c --c -- endif ! iftranspose .eq. 1 --c --c -- return -- end --c --c --c --c -- subroutine iddp_qrpiv(eps,m,n,a,krank,ind,ss) --c --c computes the pivoted QR decomposition --c of the matrix input into a, using Householder transformations, --c _i.e._, transforms the matrix a from its input value in --c to the matrix out with entry --c --c m --c out(j,indprod(k)) = Sigma q(l,j) * in(l,k), --c l=1 --c --c for all j = 1, ..., krank, and k = 1, ..., n, --c --c where in = the a from before the routine runs, --c out = the a from after the routine runs, --c out(j,k) = 0 when j > k (so that out is triangular), --c q(1:m,1), ..., q(1:m,krank) are orthonormal, --c indprod is the product of the permutations given by ind, --c (as computable via the routine permmult, --c with the permutation swapping 1 and ind(1) taken leftmost --c in the product, that swapping 2 and ind(2) taken next leftmost, --c ..., that swapping krank and ind(krank) taken rightmost), --c and with the matrix out satisfying --c --c krank --c in(j,k) = Sigma q(j,l) * out(l,indprod(k)) + epsilon(j,k), --c l=1 --c --c for all j = 1, ..., m, and k = 1, ..., n, --c --c for some matrix epsilon such that --c the root-sum-square of the entries of epsilon --c <= the root-sum-square of the entries of in * eps. --c Well, technically, this routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c input: --c eps -- relative precision of the resulting QR decomposition --c m -- first dimension of a and q --c n -- second dimension of a --c a -- matrix whose QR decomposition gets computed --c --c output: --c a -- triangular (R) factor in the QR decompositon --c of the matrix input into the same storage locations, --c with the Householder vectors stored in the part of a --c that would otherwise consist entirely of zeroes, that is, --c in a(j,k) with m >= j > k >= 1 --c krank -- numerical rank --c ind(k) -- index of the k^th pivot vector; --c the following code segment will correctly rearrange --c the product b of q and the upper triangle of out --c so that b matches the input matrix in --c to relative precision eps: --c --c copy the non-rearranged product of q and out into b --c set k to krank --c [start of loop] --c swap b(1:m,k) and b(1:m,ind(k)) --c decrement k by 1 --c if k > 0, then go to [start of loop] --c --c work: --c ss -- must be at least n real*8 words long --c --c _N.B._: This routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- integer n,m,ind(n),krank,k,j,kpiv,mm,nupdate,ifrescal -- real*8 a(m,n),ss(n),eps,feps,ssmax,scal,ssmaxin,rswap --c --c -- feps = .1d-16 --c --c --c Compute the sum of squares of the entries in each column of a, --c the maximum of all such sums, and find the first pivot --c (column with the greatest such sum). --c -- ssmax = 0 -- kpiv = 1 --c -- do k = 1,n --c -- ss(k) = 0 -- do j = 1,m -- ss(k) = ss(k)+a(j,k)**2 -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- ssmaxin = ssmax --c -- nupdate = 0 --c --c --c While ssmax > eps**2*ssmaxin, krank < m, and krank < n, --c do the following block of code, --c which ends at the statement labeled 2000. --c -- krank = 0 -- 1000 continue --c -- if(ssmax .le. eps**2*ssmaxin -- 1 .or. krank .ge. m .or. krank .ge. n) goto 2000 -- krank = krank+1 --c --c -- mm = m-krank+1 --c --c --c Perform the pivoting. --c -- ind(krank) = kpiv --c --c Swap a(1:m,krank) and a(1:m,kpiv). --c -- do j = 1,m -- rswap = a(j,krank) -- a(j,krank) = a(j,kpiv) -- a(j,kpiv) = rswap -- enddo ! j --c --c Swap ss(krank) and ss(kpiv). --c -- rswap = ss(krank) -- ss(krank) = ss(kpiv) -- ss(kpiv) = rswap --c --c -- if(krank .lt. m) then --c --c --c Compute the data for the Householder transformation --c which will zero a(krank+1,krank), ..., a(m,krank) --c when applied to a, replacing a(krank,krank) --c with the first entry of the result of the application --c of the Householder matrix to a(krank:m,krank), --c and storing entries 2 to mm of the Householder vector --c in a(krank+1,krank), ..., a(m,krank) --c (which otherwise would get zeroed upon application --c of the Householder transformation). --c -- call idd_house(mm,a(krank,krank),a(krank,krank), -- 1 a(krank+1,krank),scal) -- ifrescal = 0 --c --c --c Apply the Householder transformation --c to the lower right submatrix of a --c with upper leftmost entry at position (krank,krank+1). --c -- if(krank .lt. n) then -- do k = krank+1,n -- call idd_houseapp(mm,a(krank+1,krank),a(krank,k), -- 1 ifrescal,scal,a(krank,k)) -- enddo ! k -- endif --c --c --c Update the sums-of-squares array ss. --c -- do k = krank,n -- ss(k) = ss(k)-a(krank,k)**2 -- enddo ! k --c --c --c Find the pivot (column with the greatest sum of squares --c of its entries). --c -- ssmax = 0 -- kpiv = krank+1 --c -- if(krank .lt. n) then --c -- do k = krank+1,n --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! krank .lt. n --c --c --c Recompute the sums-of-squares and the pivot --c when ssmax first falls below --c sqrt((1000*feps)^2) * ssmaxin --c and when ssmax first falls below --c ((1000*feps)^2) * ssmaxin. --c -- if( -- 1 (ssmax .lt. sqrt((1000*feps)**2) * ssmaxin -- 2 .and. nupdate .eq. 0) .or. -- 3 (ssmax .lt. ((1000*feps)**2) * ssmaxin -- 4 .and. nupdate .eq. 1) -- 5 ) then --c -- nupdate = nupdate+1 --c -- ssmax = 0 -- kpiv = krank+1 --c -- if(krank .lt. n) then --c -- do k = krank+1,n --c -- ss(k) = 0 -- do j = krank+1,m -- ss(k) = ss(k)+a(j,k)**2 -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! krank .lt. n --c -- endif --c --c -- endif ! krank .lt. m --c --c -- goto 1000 -- 2000 continue --c --c -- return -- end --c --c --c --c -- subroutine iddr_qrpiv(m,n,a,krank,ind,ss) --c --c computes the pivoted QR decomposition --c of the matrix input into a, using Householder transformations, --c _i.e._, transforms the matrix a from its input value in --c to the matrix out with entry --c --c m --c out(j,indprod(k)) = Sigma q(l,j) * in(l,k), --c l=1 --c --c for all j = 1, ..., krank, and k = 1, ..., n, --c --c where in = the a from before the routine runs, --c out = the a from after the routine runs, --c out(j,k) = 0 when j > k (so that out is triangular), --c q(1:m,1), ..., q(1:m,krank) are orthonormal, --c indprod is the product of the permutations given by ind, --c (as computable via the routine permmult, --c with the permutation swapping 1 and ind(1) taken leftmost --c in the product, that swapping 2 and ind(2) taken next leftmost, --c ..., that swapping krank and ind(krank) taken rightmost), --c and with the matrix out satisfying --c --c min(krank,m,n) --c in(j,k) = Sigma q(j,l) * out(l,indprod(k)) --c l=1 --c --c + epsilon(j,k), --c --c for all j = 1, ..., m, and k = 1, ..., n, --c --c for some matrix epsilon whose norm is (hopefully) minimized --c by the pivoting procedure. --c Well, technically, this routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c input: --c m -- first dimension of a and q --c n -- second dimension of a --c a -- matrix whose QR decomposition gets computed --c krank -- desired rank of the output matrix --c (please note that if krank > m or krank > n, --c then the rank of the output matrix will be --c less than krank) --c --c output: --c a -- triangular (R) factor in the QR decompositon --c of the matrix input into the same storage locations, --c with the Householder vectors stored in the part of a --c that would otherwise consist entirely of zeroes, that is, --c in a(j,k) with m >= j > k >= 1 --c ind(k) -- index of the k^th pivot vector; --c the following code segment will correctly rearrange --c the product b of q and the upper triangle of out --c so that b best matches the input matrix in: --c --c copy the non-rearranged product of q and out into b --c set k to krank --c [start of loop] --c swap b(1:m,k) and b(1:m,ind(k)) --c decrement k by 1 --c if k > 0, then go to [start of loop] --c --c work: --c ss -- must be at least n real*8 words long --c --c _N.B._: This routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- integer n,m,ind(n),krank,k,j,kpiv,mm,nupdate,ifrescal, -- 1 loops,loop -- real*8 a(m,n),ss(n),ssmax,scal,ssmaxin,rswap,feps --c --c -- feps = .1d-16 --c --c --c Compute the sum of squares of the entries in each column of a, --c the maximum of all such sums, and find the first pivot --c (column with the greatest such sum). --c -- ssmax = 0 -- kpiv = 1 --c -- do k = 1,n --c -- ss(k) = 0 -- do j = 1,m -- ss(k) = ss(k)+a(j,k)**2 -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- ssmaxin = ssmax --c -- nupdate = 0 --c --c --c Set loops = min(krank,m,n). --c -- loops = krank -- if(m .lt. loops) loops = m -- if(n .lt. loops) loops = n --c -- do loop = 1,loops --c --c -- mm = m-loop+1 --c --c --c Perform the pivoting. --c -- ind(loop) = kpiv --c --c Swap a(1:m,loop) and a(1:m,kpiv). --c -- do j = 1,m -- rswap = a(j,loop) -- a(j,loop) = a(j,kpiv) -- a(j,kpiv) = rswap -- enddo ! j --c --c Swap ss(loop) and ss(kpiv). --c -- rswap = ss(loop) -- ss(loop) = ss(kpiv) -- ss(kpiv) = rswap --c --c -- if(loop .lt. m) then --c --c --c Compute the data for the Householder transformation --c which will zero a(loop+1,loop), ..., a(m,loop) --c when applied to a, replacing a(loop,loop) --c with the first entry of the result of the application --c of the Householder matrix to a(loop:m,loop), --c and storing entries 2 to mm of the Householder vector --c in a(loop+1,loop), ..., a(m,loop) --c (which otherwise would get zeroed upon application --c of the Householder transformation). --c -- call idd_house(mm,a(loop,loop),a(loop,loop), -- 1 a(loop+1,loop),scal) -- ifrescal = 0 --c --c --c Apply the Householder transformation --c to the lower right submatrix of a --c with upper leftmost entry at position (loop,loop+1). --c -- if(loop .lt. n) then -- do k = loop+1,n -- call idd_houseapp(mm,a(loop+1,loop),a(loop,k), -- 1 ifrescal,scal,a(loop,k)) -- enddo ! k -- endif --c --c --c Update the sums-of-squares array ss. --c -- do k = loop,n -- ss(k) = ss(k)-a(loop,k)**2 -- enddo ! k --c --c --c Find the pivot (column with the greatest sum of squares --c of its entries). --c -- ssmax = 0 -- kpiv = loop+1 --c -- if(loop .lt. n) then --c -- do k = loop+1,n --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! loop .lt. n --c --c --c Recompute the sums-of-squares and the pivot --c when ssmax first falls below --c sqrt((1000*feps)^2) * ssmaxin --c and when ssmax first falls below --c ((1000*feps)^2) * ssmaxin. --c -- if( -- 1 (ssmax .lt. sqrt((1000*feps)**2) * ssmaxin -- 2 .and. nupdate .eq. 0) .or. -- 3 (ssmax .lt. ((1000*feps)**2) * ssmaxin -- 4 .and. nupdate .eq. 1) -- 5 ) then --c -- nupdate = nupdate+1 --c -- ssmax = 0 -- kpiv = loop+1 --c -- if(loop .lt. n) then --c -- do k = loop+1,n --c -- ss(k) = 0 -- do j = loop+1,m -- ss(k) = ss(k)+a(j,k)**2 -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! loop .lt. n --c -- endif --c --c -- endif ! loop .lt. m --c --c -- enddo ! loop --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_sfft.f b/scipy/linalg/src/id_dist/src/idd_sfft.f -deleted file mode 100644 -index e46045ac2..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_sfft.f -+++ /dev/null -@@ -1,443 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idd_sffti initializes routine idd_sfft. --c --c routine idd_sfft rapidly computes a subset of the entries --c of the DFT of a vector, composed with permutation matrices --c both on input and on output. --c --c routine idd_ldiv finds the greatest integer less than or equal --c to a specified integer, that is divisible by another (larger) --c specified integer. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idd_ldiv(l,n,m) --c --c finds the greatest integer less than or equal to l --c that divides n. --c --c input: --c l -- integer at least as great as m --c n -- integer divisible by m --c --c output: --c m -- greatest integer less than or equal to l that divides n --c -- implicit none -- integer n,l,m --c --c -- m = l --c -- 1000 continue -- if(m*(n/m) .eq. n) goto 2000 --c -- m = m-1 -- goto 1000 --c -- 2000 continue --c --c -- return -- end --c --c --c --c -- subroutine idd_sffti(l,ind,n,wsave) --c --c initializes wsave for using routine idd_sfft. --c --c input: --c l -- number of pairs of entries in the output of idd_sfft --c to compute --c ind -- indices of the pairs of entries in the output --c of idd_sfft to compute; the indices must be chosen --c in the range from 1 to n/2 --c n -- length of the vector to be transformed --c --c output: --c wsave -- array needed by routine idd_sfft for processing --c (the present routine does not use the last n elements --c of wsave, but routine idd_sfft does) --c -- implicit none -- integer l,ind(l),n -- complex*16 wsave(2*l+15+4*n) --c --c -- if(l .eq. 1) call idd_sffti1(ind,n,wsave) -- if(l .gt. 1) call idd_sffti2(l,ind,n,wsave) --c --c -- return -- end --c --c --c --c -- subroutine idd_sffti1(ind,n,wsave) --c --c routine idd_sffti serves as a wrapper around --c the present routine; please see routine idd_sffti --c for documentation. --c -- implicit none -- integer ind,n,k -- real*8 r1,twopi,wsave(2*(2+15+4*n)),fact --c -- r1 = 1 -- twopi = 2*4*atan(r1) --c --c -- fact = 1/sqrt(r1*n) --c --c -- do k = 1,n -- wsave(k) = cos(twopi*(k-1)*ind/(r1*n))*fact -- enddo ! k --c -- do k = 1,n -- wsave(n+k) = -sin(twopi*(k-1)*ind/(r1*n))*fact -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_sffti2(l,ind,n,wsave) --c --c routine idd_sffti serves as a wrapper around --c the present routine; please see routine idd_sffti --c for documentation. --c -- implicit none -- integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k -- real*8 r1,twopi,fact -- complex*16 wsave(2*l+15+4*n),ci,twopii --c -- ci = (0,1) -- r1 = 1 -- twopi = 2*4*atan(r1) -- twopii = twopi*ci --c --c --c Determine the block lengths for the FFTs. --c -- call idd_ldiv(l,n,nblock) -- m = n/nblock --c --c --c Initialize wsave for using routine dfftf. --c -- call dffti(nblock,wsave) --c --c --c Calculate the coefficients in the linear combinations --c needed for the direct portion of the calculation. --c -- fact = 1/sqrt(r1*n) --c -- ii = 2*l+15 --c -- do j = 1,l --c --c -- i = ind(j) --c --c -- if(i .le. n/2-m/2) then --c -- idivm = (i-1)/m -- imodm = (i-1)-m*idivm --c -- do k = 1,m -- wsave(ii+m*(j-1)+k) = exp(-twopii*(k-1)*imodm/(r1*m)) -- 1 * exp(-twopii*(k-1)*(idivm+1)/(r1*n)) * fact -- enddo ! k --c -- endif ! i .le. n/2-m/2 --c --c -- if(i .gt. n/2-m/2) then --c -- idivm = i/(m/2) -- imodm = i-(m/2)*idivm --c -- do k = 1,m -- wsave(ii+m*(j-1)+k) = exp(-twopii*(k-1)*imodm/(r1*m)) -- 1 * fact -- enddo ! k --c -- endif ! i .gt. n/2-m/2 --c --c -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idd_sfft(l,ind,n,wsave,v) --c --c computes a subset of the entries of the DFT of v, --c composed with permutation matrices both on input and on output, --c via a two-stage procedure (debugging code routine dfftf2 above --c is supposed to calculate the full vector from which idd_sfft --c returns a subset of the entries, when dfftf2 has --c the same parameter nblock as in the present routine). --c --c input: --c l -- number of pairs of entries in the output to compute --c ind -- indices of the pairs of entries in the output --c to compute; the indices must be chosen --c in the range from 1 to n/2 --c n -- length of v; n must be a positive integer power of 2 --c v -- vector to be transformed --c wsave -- processing array initialized by routine idd_sffti --c --c output: --c v -- pairs of entries indexed by ind are given --c their appropriately transformed values --c --c _N.B._: n must be a positive integer power of 2. --c --c references: --c Sorensen and Burrus, "Efficient computation of the DFT with --c only a subset of input or output points," --c IEEE Transactions on Signal Processing, 41 (3): 1184-1200, --c 1993. --c Woolfe, Liberty, Rokhlin, Tygert, "A fast randomized algorithm --c for the approximation of matrices," Applied and --c Computational Harmonic Analysis, 25 (3): 335-366, 2008; --c Section 3.3. --c -- implicit none -- integer l,ind(l),n -- real*8 v(n) -- complex*16 wsave(2*l+15+4*n) --c --c -- if(l .eq. 1) call idd_sfft1(ind,n,v,wsave) -- if(l .gt. 1) call idd_sfft2(l,ind,n,v,wsave) --c --c -- return -- end --c --c --c --c -- subroutine idd_sfft1(ind,n,v,wsave) --c --c routine idd_sfft serves as a wrapper around --c the present routine; please see routine idd_sfft --c for documentation. --c -- implicit none -- integer ind,n,k -- real*8 v(n),r1,twopi,sumr,sumi,fact,wsave(2*(2+15+4*n)) --c -- r1 = 1 -- twopi = 2*4*atan(r1) --c --c -- if(ind .lt. n/2) then --c --c -- sumr = 0 --c -- do k = 1,n -- sumr = sumr+wsave(k)*v(k) -- enddo ! k --c --c -- sumi = 0 --c -- do k = 1,n -- sumi = sumi+wsave(n+k)*v(k) -- enddo ! k --c --c -- endif ! ind .lt. n/2 --c --c -- if(ind .eq. n/2) then --c --c -- fact = 1/sqrt(r1*n) --c --c -- sumr = 0 --c -- do k = 1,n -- sumr = sumr+v(k) -- enddo ! k --c -- sumr = sumr*fact --c --c -- sumi = 0 --c -- do k = 1,n/2 -- sumi = sumi+v(2*k-1) -- sumi = sumi-v(2*k) -- enddo ! k --c -- sumi = sumi*fact --c --c -- endif ! ind .eq. n/2 --c --c -- v(2*ind-1) = sumr -- v(2*ind) = sumi --c --c -- return -- end --c --c --c --c -- subroutine idd_sfft2(l,ind,n,v,wsave) --c --c routine idd_sfft serves as a wrapper around --c the present routine; please see routine idd_sfft --c for documentation. --c -- implicit none -- integer n,m,l,k,j,ind(l),i,idivm,nblock,ii,iii,imodm -- real*8 r1,twopi,v(n),rsum,fact -- complex*16 wsave(2*l+15+4*n),ci,sum --c -- ci = (0,1) -- r1 = 1 -- twopi = 2*4*atan(r1) --c --c --c Determine the block lengths for the FFTs. --c -- call idd_ldiv(l,n,nblock) --c --c -- m = n/nblock --c --c --c FFT each block of length nblock of v. --c -- do k = 1,m -- call dfftf(nblock,v(nblock*(k-1)+1),wsave) -- enddo ! k --c --c --c Transpose v to obtain wsave(2*l+15+2*n+1 : 2*l+15+3*n). --c -- iii = 2*l+15+2*n --c -- do k = 1,m -- do j = 1,nblock/2-1 -- wsave(iii+m*(j-1)+k) = v(nblock*(k-1)+2*j) -- 1 + ci*v(nblock*(k-1)+2*j+1) -- enddo ! j -- enddo ! k --c --c Handle the purely real frequency components separately. --c -- do k = 1,m -- wsave(iii+m*(nblock/2-1)+k) = v(nblock*(k-1)+nblock) -- wsave(iii+m*(nblock/2)+k) = v(nblock*(k-1)+1) -- enddo ! k --c --c --c Directly calculate the desired entries of v. --c -- ii = 2*l+15 --c -- do j = 1,l --c --c -- i = ind(j) --c --c -- if(i .le. n/2-m/2) then --c -- idivm = (i-1)/m -- imodm = (i-1)-m*idivm --c -- sum = 0 --c -- do k = 1,m -- sum = sum + wsave(iii+m*idivm+k) * wsave(ii+m*(j-1)+k) -- enddo ! k --c -- v(2*i-1) = sum -- v(2*i) = -ci*sum --c -- endif ! i .le. n/2-m/2 --c --c -- if(i .gt. n/2-m/2) then --c -- if(i .lt. n/2) then --c -- idivm = i/(m/2) -- imodm = i-(m/2)*idivm --c -- sum = 0 --c -- do k = 1,m -- sum = sum + wsave(iii+m*(nblock/2)+k) -- 1 * wsave(ii+m*(j-1)+k) -- enddo ! k --c -- v(2*i-1) = sum -- v(2*i) = -ci*sum --c -- endif --c -- if(i .eq. n/2) then --c -- fact = 1/sqrt(r1*n) --c --c -- rsum = 0 --c -- do k = 1,m -- rsum = rsum + wsave(iii+m*(nblock/2)+k) -- enddo ! k --c -- v(n-1) = rsum*fact --c --c -- rsum = 0 --c -- do k = 1,m/2 -- rsum = rsum + wsave(iii+m*(nblock/2)+2*k-1) -- rsum = rsum - wsave(iii+m*(nblock/2)+2*k) -- enddo ! k --c -- v(n) = rsum*fact --c -- endif --c -- endif ! i .gt. n/2-m/2 --c --c -- enddo ! j --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_snorm.f b/scipy/linalg/src/id_dist/src/idd_snorm.f -deleted file mode 100644 -index c718ce12f..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_snorm.f -+++ /dev/null -@@ -1,400 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idd_snorm estimates the spectral norm --c of a matrix specified by routines for applying the matrix --c and its transpose to arbitrary vectors. This routine uses --c the power method with a random starting vector. --c --c routine idd_diffsnorm estimates the spectral norm --c of the difference between two matrices specified by routines --c for applying the matrices and their transposes --c to arbitrary vectors. This routine uses --c the power method with a random starting vector. --c --c routine idd_enorm calculates the Euclidean norm of a vector. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idd_snorm(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,its,snorm,v,u) --c --c estimates the spectral norm of a matrix a specified --c by a routine matvec for applying a to an arbitrary vector, --c and by a routine matvect for applying a^T --c to an arbitrary vector. This routine uses the power method --c with a random starting vector. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c matvect -- routine which applies the transpose of a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvect(m,x,n,y,p1t,p2t,p3t,p4t), --c --c where m is the length of x, --c x is the vector to which the transpose of a --c is to be applied, --c n is the length of y, --c y is the product of the transpose of a and x, --c and p1t, p2t, p3t, and p4t are user-specified --c parameters --c p1t -- parameter to be passed to routine matvect --c p2t -- parameter to be passed to routine matvect --c p3t -- parameter to be passed to routine matvect --c p4t -- parameter to be passed to routine matvect --c matvec -- routine which applies the matrix a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which a is to be applied, --c m is the length of y, --c y is the product of a and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c its -- number of iterations of the power method to conduct --c --c output: --c snorm -- estimate of the spectral norm of a --c v -- estimate of a normalized right singular vector --c corresponding to the greatest singular value of a --c --c work: --c u -- must be at least m real*8 elements long --c --c reference: --c Kuczynski and Wozniakowski, "Estimating the largest eigenvalue --c by the power and Lanczos algorithms with a random start," --c SIAM Journal on Matrix Analysis and Applications, --c 13 (4): 1992, 1094-1122. --c -- implicit none -- integer m,n,its,it,k -- real*8 snorm,enorm,p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m),v(n) -- external matvect,matvec --c --c --c Fill the real and imaginary parts of each entry --c of the initial vector v with i.i.d. random variables --c drawn uniformly from [-1,1]. --c -- call id_srand(n,v) --c -- do k = 1,n -- v(k) = 2*v(k)-1 -- enddo ! k --c --c --c Normalize v. --c -- call idd_enorm(n,v,enorm) --c -- do k = 1,n -- v(k) = v(k)/enorm -- enddo ! k --c --c -- do it = 1,its --c --c Apply a to v, obtaining u. --c -- call matvec(n,v,m,u,p1,p2,p3,p4) --c --c Apply a^T to u, obtaining v. --c -- call matvect(m,u,n,v,p1t,p2t,p3t,p4t) --c --c Normalize v. --c -- call idd_enorm(n,v,snorm) --c -- if(snorm .gt. 0) then --c -- do k = 1,n -- v(k) = v(k)/snorm -- enddo ! k --c -- endif --c -- snorm = sqrt(snorm) --c -- enddo ! it --c --c -- return -- end --c --c --c --c -- subroutine idd_enorm(n,v,enorm) --c --c computes the Euclidean norm of v, the square root --c of the sum of the squares of the entries of v. --c --c input: --c n -- length of v --c v -- vector whose Euclidean norm is to be calculated --c --c output: --c enorm -- Euclidean norm of v --c -- implicit none -- integer n,k -- real*8 enorm,v(n) --c --c -- enorm = 0 --c -- do k = 1,n -- enorm = enorm+v(k)**2 -- enddo ! k --c -- enorm = sqrt(enorm) --c --c -- return -- end --c --c --c --c -- subroutine idd_diffsnorm(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvect2,p1t2,p2t2,p3t2,p4t2, -- 2 matvec,p1,p2,p3,p4, -- 3 matvec2,p12,p22,p32,p42,its,snorm,w) --c --c estimates the spectral norm of the difference between matrices --c a and a2, where a is specified by routines matvec and matvect --c for applying a and a^T to arbitrary vectors, --c and a2 is specified by routines matvec2 and matvect2 --c for applying a2 and (a2)^T to arbitrary vectors. --c This routine uses the power method --c with a random starting vector. --c --c input: --c m -- number of rows in a, as well as the number of rows in a2 --c n -- number of columns in a, as well as the number of columns --c in a2 --c matvect -- routine which applies the transpose of a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvect(m,x,n,y,p1t,p2t,p3t,p4t), --c --c where m is the length of x, --c x is the vector to which the transpose of a --c is to be applied, --c n is the length of y, --c y is the product of the transpose of a and x, --c and p1t, p2t, p3t, and p4t are user-specified --c parameters --c p1t -- parameter to be passed to routine matvect --c p2t -- parameter to be passed to routine matvect --c p3t -- parameter to be passed to routine matvect --c p4t -- parameter to be passed to routine matvect --c matvect2 -- routine which applies the transpose of a2 --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvect2(m,x,n,y,p1t2,p2t2,p3t2,p4t2), --c --c where m is the length of x, --c x is the vector to which the transpose of a2 --c is to be applied, --c n is the length of y, --c y is the product of the transpose of a2 and x, --c and p1t2, p2t2, p3t2, and p4t2 are user-specified --c parameters --c p1t2 -- parameter to be passed to routine matvect2 --c p2t2 -- parameter to be passed to routine matvect2 --c p3t2 -- parameter to be passed to routine matvect2 --c p4t2 -- parameter to be passed to routine matvect2 --c matvec -- routine which applies the matrix a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which a is to be applied, --c m is the length of y, --c y is the product of a and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c matvec2 -- routine which applies the matrix a2 --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec2(n,x,m,y,p12,p22,p32,p42), --c --c where n is the length of x, --c x is the vector to which a2 is to be applied, --c m is the length of y, --c y is the product of a2 and x, and --c p12, p22, p32, and p42 are user-specified parameters --c p12 -- parameter to be passed to routine matvec2 --c p22 -- parameter to be passed to routine matvec2 --c p32 -- parameter to be passed to routine matvec2 --c p42 -- parameter to be passed to routine matvec2 --c its -- number of iterations of the power method to conduct --c --c output: --c snorm -- estimate of the spectral norm of a-a2 --c --c work: --c w -- must be at least 3*m+3*n real*8 elements long --c --c reference: --c Kuczynski and Wozniakowski, "Estimating the largest eigenvalue --c by the power and Lanczos algorithms with a random start," --c SIAM Journal on Matrix Analysis and Applications, --c 13 (4): 1992, 1094-1122. --c -- implicit none -- integer m,n,its,lw,iu,lu,iu1,lu1,iu2,lu2, -- 1 iv,lv,iv1,lv1,iv2,lv2 -- real*8 snorm,p1t,p2t,p3t,p4t,p1t2,p2t2,p3t2,p4t2, -- 1 p1,p2,p3,p4,p12,p22,p32,p42,w(3*m+3*n) -- external matvect,matvec,matvect2,matvec2 --c --c --c Allocate memory in w. --c -- lw = 0 --c -- iu = lw+1 -- lu = m -- lw = lw+lu --c -- iu1 = lw+1 -- lu1 = m -- lw = lw+lu1 --c -- iu2 = lw+1 -- lu2 = m -- lw = lw+lu2 --c -- iv = lw+1 -- lv = n -- lw = lw+1 --c -- iv1 = lw+1 -- lv1 = n -- lw = lw+lv1 --c -- iv2 = lw+1 -- lv2 = n -- lw = lw+lv2 --c --c -- call idd_diffsnorm0(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvect2,p1t2,p2t2,p3t2,p4t2, -- 2 matvec,p1,p2,p3,p4, -- 3 matvec2,p12,p22,p32,p42, -- 4 its,snorm,w(iu),w(iu1),w(iu2), -- 5 w(iv),w(iv1),w(iv2)) --c --c -- return -- end --c --c --c --c -- subroutine idd_diffsnorm0(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvect2,p1t2,p2t2,p3t2,p4t2, -- 2 matvec,p1,p2,p3,p4, -- 3 matvec2,p12,p22,p32,p42, -- 4 its,snorm,u,u1,u2,v,v1,v2) --c --c routine idd_diffsnorm serves as a memory wrapper --c for the present routine. (Please see routine idd_diffsnorm --c for further documentation.) --c -- implicit none -- integer m,n,its,it,k -- real*8 snorm,enorm,p1t,p2t,p3t,p4t,p1t2,p2t2,p3t2,p4t2, -- 1 p1,p2,p3,p4,p12,p22,p32,p42,u(m),u1(m),u2(m), -- 2 v(n),v1(n),v2(n) -- external matvect,matvec,matvect2,matvec2 --c --c --c Fill the real and imaginary parts of each entry --c of the initial vector v with i.i.d. random variables --c drawn uniformly from [-1,1]. --c -- call id_srand(n,v) --c -- do k = 1,n -- v(k) = 2*v(k)-1 -- enddo ! k --c --c --c Normalize v. --c -- call idd_enorm(n,v,enorm) --c -- do k = 1,n -- v(k) = v(k)/enorm -- enddo ! k --c --c -- do it = 1,its --c --c Apply a and a2 to v, obtaining u1 and u2. --c -- call matvec(n,v,m,u1,p1,p2,p3,p4) -- call matvec2(n,v,m,u2,p12,p22,p32,p42) --c --c Form u = u1-u2. --c -- do k = 1,m -- u(k) = u1(k)-u2(k) -- enddo ! k --c --c Apply a^T and (a2)^T to u, obtaining v1 and v2. --c -- call matvect(m,u,n,v1,p1t,p2t,p3t,p4t) -- call matvect2(m,u,n,v2,p1t2,p2t2,p3t2,p4t2) --c --c Form v = v1-v2. --c -- do k = 1,n -- v(k) = v1(k)-v2(k) -- enddo ! k --c --c Normalize v. --c -- call idd_enorm(n,v,snorm) --c -- if(snorm .gt. 0) then --c -- do k = 1,n -- v(k) = v(k)/snorm -- enddo ! k --c -- endif --c -- snorm = sqrt(snorm) --c -- enddo ! it --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idd_svd.f b/scipy/linalg/src/id_dist/src/idd_svd.f -deleted file mode 100644 -index 969422b8c..000000000 ---- a/scipy/linalg/src/id_dist/src/idd_svd.f -+++ /dev/null -@@ -1,409 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddr_svd computes an approximation of specified rank --c to a given matrix, in the usual SVD form U S V^T, --c where U has orthonormal columns, V has orthonormal columns, --c and S is diagonal. --c --c routine iddp_svd computes an approximation of specified --c precision to a given matrix, in the usual SVD form U S V^T, --c where U has orthonormal columns, V has orthonormal columns, --c and S is diagonal. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddr_svd(m,n,a,krank,u,v,s,ier,r) --c --c constructs a rank-krank SVD u diag(s) v^T approximating a, --c where u is an m x krank matrix whose columns are orthonormal, --c v is an n x krank matrix whose columns are orthonormal, --c and diag(s) is a diagonal krank x krank matrix whose entries --c are all nonnegative. This routine combines a QR code --c (which is based on plane/Householder reflections) --c with the LAPACK routine dgesdd. --c --c input: --c m -- first dimension of a and u --c n -- second dimension of a, and first dimension of v --c a -- matrix to be SVD'd --c krank -- desired rank of the approximation to a --c --c output: --c u -- left singular vectors of a corresponding --c to the k greatest singular values of a --c v -- right singular vectors of a corresponding --c to the k greatest singular values of a --c s -- k greatest singular values of a --c ier -- 0 when the routine terminates successfully; --c nonzero when the routine encounters an error --c --c work: --c r -- must be at least --c (krank+2)*n+8*min(m,n)+15*krank**2+8*krank --c real*8 elements long --c --c _N.B._: This routine destroys a. Also, please beware that --c the source code for this routine could be clearer. --c -- implicit none -- character*1 jobz -- integer m,n,k,krank,iftranspose,ldr,ldu,ldvt,lwork, -- 1 info,j,ier,io -- real*8 a(m,n),u(m,krank),v(n*krank),s(krank),r(*) --c --c -- io = 8*min(m,n) --c --c -- ier = 0 --c --c --c Compute a pivoted QR decomposition of a. --c -- call iddr_qrpiv(m,n,a,krank,r,r(io+1)) --c --c --c Extract R from the QR decomposition. --c -- call idd_retriever(m,n,a,krank,r(io+1)) --c --c --c Rearrange R according to ind (which is stored in r). --c -- call idd_permuter(krank,r,krank,n,r(io+1)) --c --c --c Use LAPACK to SVD R, --c storing the krank (krank x 1) left singular vectors --c in r(io+krank*n+1 : io+krank*n+krank*krank). --c -- jobz = 'S' -- ldr = krank -- lwork = 2*(3*krank**2+n+4*krank**2+4*krank) -- ldu = krank -- ldvt = krank --c -- call dgesdd(jobz,krank,n,r(io+1),ldr,s,r(io+krank*n+1),ldu, -- 1 v,ldvt,r(io+krank*n+krank*krank+1),lwork,r,info) --c -- if(info .ne. 0) then -- ier = info -- return -- endif --c --c --c Multiply the U from R from the left by Q to obtain the U --c for A. --c -- do k = 1,krank --c -- do j = 1,krank -- u(j,k) = r(io+krank*n+j+krank*(k-1)) -- enddo ! j --c -- do j = krank+1,m -- u(j,k) = 0 -- enddo ! j --c -- enddo ! k --c -- iftranspose = 0 -- call idd_qmatmat(iftranspose,m,n,a,krank,krank,u,r) --c --c --c Transpose v to obtain r. --c -- call idd_transer(krank,n,v,r) --c --c --c Copy r into v. --c -- do k = 1,n*krank -- v(k) = r(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine iddp_svd(lw,eps,m,n,a,krank,iu,iv,is,w,ier) --c --c constructs a rank-krank SVD U Sigma V^T approximating a --c to precision eps, where U is an m x krank matrix whose --c columns are orthonormal, V is an n x krank matrix whose --c columns are orthonormal, and Sigma is a diagonal krank x krank --c matrix whose entries are all nonnegative. --c The entries of U are stored in w, starting at w(iu); --c the entries of V are stored in w, starting at w(iv). --c The diagonal entries of Sigma are stored in w, --c starting at w(is). This routine combines a QR code --c (which is based on plane/Householder reflections) --c with the LAPACK routine dgesdd. --c --c input: --c lw -- maximum usable length of w (in real*8 elements) --c eps -- precision to which the SVD approximates a --c m -- first dimension of a and u --c n -- second dimension of a, and first dimension of v --c a -- matrix to be SVD'd --c --c output: --c krank -- rank of the approximation to a --c iu -- index in w of the first entry of the matrix --c of orthonormal left singular vectors of a --c iv -- index in w of the first entry of the matrix --c of orthonormal right singular vectors of a --c is -- index in w of the first entry of the array --c of singular values of a --c w -- array containing the singular values and singular vectors --c of a; w doubles as a work array, and so must be at least --c (krank+1)*(m+2*n+9)+8*min(m,n)+15*krank**2 --c real*8 elements long, where krank is the rank --c output by the present routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lw is too small; --c other nonzero values when dgesdd bombs --c --c _N.B._: This routine destroys a. Also, please beware that --c the source code for this routine could be clearer. --c w must be at least --c (krank+1)*(m+2*n+9)+8*min(m,n)+15*krank**2 --c real*8 elements long, where krank is the rank --c output by the present routine. --c -- implicit none -- character*1 jobz -- integer m,n,k,krank,iftranspose,ldr,ldu,ldvt,lwork, -- 1 info,j,ier,io,iu,iv,is,ivi,isi,lw,lu,lv,ls -- real*8 a(m,n),w(*),eps --c --c -- io = 8*min(m,n) --c --c -- ier = 0 --c --c --c Compute a pivoted QR decomposition of a. --c -- call iddp_qrpiv(eps,m,n,a,krank,w,w(io+1)) --c --c -- if(krank .gt. 0) then --c --c --c Extract R from the QR decomposition. --c -- call idd_retriever(m,n,a,krank,w(io+1)) --c --c --c Rearrange R according to ind (which is stored in w). --c -- call idd_permuter(krank,w,krank,n,w(io+1)) --c --c --c Use LAPACK to SVD R, --c storing the krank (krank x 1) left singular vectors --c in w(io+krank*n+1 : io+krank*n+krank*krank). --c -- jobz = 'S' -- ldr = krank -- lwork = 2*(3*krank**2+n+4*krank**2+4*krank) -- ldu = krank -- ldvt = krank --c -- ivi = io+krank*n+krank*krank+lwork+1 -- lv = n*krank --c -- isi = ivi+lv -- ls = krank --c -- if(lw .lt. isi+ls+m*krank-1) then -- ier = -1000 -- return -- endif --c -- call dgesdd(jobz,krank,n,w(io+1),ldr,w(isi),w(io+krank*n+1), -- 1 ldu,w(ivi),ldvt,w(io+krank*n+krank*krank+1), -- 2 lwork,w,info) --c -- if(info .ne. 0) then -- ier = info -- return -- endif --c --c --c Transpose w(ivi:ivi+lv-1) to obtain V. --c -- iv = 1 -- call idd_transer(krank,n,w(ivi),w(iv)) --c --c --c Copy w(isi:isi+ls-1) into w(is:is+ls-1). --c -- is = iv+lv --c -- do k = 1,ls -- w(is+k-1) = w(isi+k-1) -- enddo ! k --c --c --c Multiply the U from R from the left by Q to obtain the U --c for A. --c -- iu = is+ls -- lu = m*krank --c -- do k = 1,krank --c -- do j = 1,krank -- w(iu-1+j+krank*(k-1)) = w(io+krank*n+j+krank*(k-1)) -- enddo ! j --c -- enddo ! k --c -- do k = krank,1,-1 --c -- do j = m,krank+1,-1 -- w(iu-1+j+m*(k-1)) = 0 -- enddo ! j --c -- do j = krank,1,-1 -- w(iu-1+j+m*(k-1)) = w(iu-1+j+krank*(k-1)) -- enddo ! j --c -- enddo ! k --c -- iftranspose = 0 -- call idd_qmatmat(iftranspose,m,n,a,krank,krank,w(iu), -- 1 w(iu+lu+1)) --c --c -- endif ! krank .gt. 0 --c --c -- return -- end --c --c --c --c -- subroutine idd_permuter(krank,ind,m,n,a) --c --c permutes the columns of a according to ind obtained --c from routine iddr_qrpiv or iddp_qrpiv, assuming that --c a = q r from iddr_qrpiv or iddp_qrpiv. --c --c input: --c krank -- rank specified to routine iddr_qrpiv --c or obtained from routine iddp_qrpiv --c ind -- indexing array obtained from routine iddr_qrpiv --c or iddp_qrpiv --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix to be rearranged --c --c output: --c a -- rearranged matrix --c -- implicit none -- integer k,krank,m,n,j,ind(krank) -- real*8 rswap,a(m,n) --c --c -- do k = krank,1,-1 -- do j = 1,m --c -- rswap = a(j,k) -- a(j,k) = a(j,ind(k)) -- a(j,ind(k)) = rswap --c -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_retriever(m,n,a,krank,r) --c --c extracts R in the QR decomposition specified by the output a --c of the routine iddr_qrpiv or iddp_qrpiv --c --c input: --c m -- first dimension of a --c n -- second dimension of a and r --c a -- output of routine iddr_qrpiv or iddp_qrpiv --c krank -- rank specified to routine iddr_qrpiv, --c or output by routine iddp_qrpiv --c --c output: --c r -- triangular factor in the QR decomposition specified --c by the output a of the routine iddr_qrpiv or iddp_qrpiv --c -- implicit none -- integer m,n,j,k,krank -- real*8 a(m,n),r(krank,n) --c --c --c Copy a into r and zero out the appropriate --c Householder vectors that are stored in one triangle of a. --c -- do k = 1,n -- do j = 1,krank -- r(j,k) = a(j,k) -- enddo ! j -- enddo ! k --c -- do k = 1,n -- if(k .lt. krank) then -- do j = k+1,krank -- r(j,k) = 0 -- enddo ! j -- endif -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idd_transer(m,n,a,at) --c --c forms the transpose at of a. --c --c input: --c m -- first dimension of a and second dimension of at --c n -- second dimension of a and first dimension of at --c a -- matrix to be transposed --c --c output: --c at -- transpose of a --c -- implicit none -- integer m,n,j,k -- real*8 a(m,n),at(n,m) --c --c -- do k = 1,n -- do j = 1,m -- at(k,j) = a(j,k) -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddp_aid.f b/scipy/linalg/src/id_dist/src/iddp_aid.f -deleted file mode 100644 -index f3f9ddfdd..000000000 ---- a/scipy/linalg/src/id_dist/src/iddp_aid.f -+++ /dev/null -@@ -1,386 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddp_aid computes the ID, to a specified precision, --c of an arbitrary matrix. This routine is randomized. --c --c routine idd_estrank estimates the numerical rank, --c to a specified precision, of an arbitrary matrix. --c This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddp_aid(eps,m,n,a,work,krank,list,proj) --c --c computes the ID of the matrix a, i.e., lists in list --c the indices of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon dimensioned epsilon(m,n-krank) --c such that the greatest singular value of epsilon --c <= the greatest singular value of a * eps. --c --c input: --c eps -- precision to which the ID is to be computed --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix to be decomposed; the present routine does not --c alter a --c work -- initialization array that has been constructed --c by routine idd_frmi --c --c output: --c krank -- numerical rank of a to precision eps --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd; --c proj doubles as a work array in the present routine, so --c proj must be at least n*(2*n2+1)+n2+1 real*8 elements --c long, where n2 is the greatest integer less than --c or equal to m, such that n2 is a positive integer --c power of two. --c --c _N.B._: The algorithm used by this routine is randomized. --c proj must be at least n*(2*n2+1)+n2+1 real*8 elements --c long, where n2 is the greatest integer less than --c or equal to m, such that n2 is a positive integer --c power of two. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,list(n),krank,kranki,n2 -- real*8 eps,a(m,n),proj(*),work(17*m+70) --c --c --c Allocate memory in proj. --c -- n2 = work(2) --c --c --c Find the rank of a. --c -- call idd_estrank(eps,m,n,a,work,kranki,proj) --c --c -- if(kranki .eq. 0) call iddp_aid0(eps,m,n,a,krank,list,proj, -- 1 proj(m*n+1)) --c -- if(kranki .ne. 0) call iddp_aid1(eps,n2,n,kranki,proj, -- 1 krank,list,proj(n2*n+1)) --c --c -- return -- end --c --c --c --c -- subroutine iddp_aid0(eps,m,n,a,krank,list,proj,rnorms) --c --c uses routine iddp_id to ID a without modifying its entries --c (in contrast to the usual behavior of iddp_id). --c --c input: --c eps -- precision of the decomposition to be constructed --c m -- first dimension of a --c n -- second dimension of a --c --c output: --c krank -- numerical rank of the ID --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns in a; --c proj doubles as a work array in the present routine, so --c must be at least m*n real*8 elements long --c --c work: --c rnorms -- must be at least n real*8 elements long --c --c _N.B._: proj must be at least m*n real*8 elements long --c -- implicit none -- integer m,n,krank,list(n),j,k -- real*8 eps,a(m,n),proj(m,n),rnorms(n) --c --c --c Copy a into proj. --c -- do k = 1,n -- do j = 1,m -- proj(j,k) = a(j,k) -- enddo ! j -- enddo ! k --c --c --c ID proj. --c -- call iddp_id(eps,m,n,proj,krank,list,rnorms) --c --c -- return -- end --c --c --c --c -- subroutine iddp_aid1(eps,n2,n,kranki,proj,krank,list,rnorms) --c --c IDs the uppermost kranki x n block of the n2 x n matrix --c input as proj. --c --c input: --c eps -- precision of the decomposition to be constructed --c n2 -- first dimension of proj as input --c n -- second dimension of proj as input --c kranki -- number of rows to extract from proj --c proj -- matrix containing the kranki x n block to be ID'd --c --c output: --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd --c krank -- numerical rank of the ID --c list -- indices of the columns in the ID --c --c work: --c rnorms -- must be at least n real*8 elements long --c -- implicit none -- integer n,n2,kranki,krank,list(n),j,k -- real*8 eps,proj(n2*n),rnorms(n) --c --c --c Move the uppermost kranki x n block of the n2 x n matrix proj --c to the beginning of proj. --c -- do k = 1,n -- do j = 1,kranki -- proj(j+kranki*(k-1)) = proj(j+n2*(k-1)) -- enddo ! j -- enddo ! k --c --c --c ID proj. --c -- call iddp_id(eps,kranki,n,proj,krank,list,rnorms) --c --c -- return -- end --c --c --c --c -- subroutine idd_estrank(eps,m,n,a,w,krank,ra) --c --c estimates the numerical rank krank of an m x n matrix a --c to precision eps. This routine applies n2 random vectors --c to a, obtaining ra, where n2 is the greatest integer --c less than or equal to m such that n2 is a positive integer --c power of two. krank is typically about 8 higher than --c the actual numerical rank. --c --c input: --c eps -- precision defining the numerical rank --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix whose rank is to be estimated --c w -- initialization array that has been constructed --c by routine idd_frmi --c --c output: --c krank -- estimate of the numerical rank of a; --c this routine returns krank = 0 when the actual --c numerical rank is nearly full (that is, --c greater than n - 8 or n2 - 8) --c ra -- product of an n2 x m random matrix and the m x n matrix --c a, where n2 is the greatest integer less than or equal --c to m such that n2 is a positive integer power of two; --c ra doubles as a work array in the present routine, and so --c must be at least n*n2+(n+1)*(n2+1) real*8 elements long --c --c _N.B._: ra must be at least n*n2+(n2+1)*(n+1) real*8 --c elements long for use in the present routine --c (here, n2 is the greatest integer less than or equal --c to m, such that n2 is a positive integer power of two). --c This routine returns krank = 0 when the actual --c numerical rank is nearly full. --c -- implicit none -- integer m,n,krank,n2,irat,lrat,iscal,lscal,ira,lra,lra2 -- real*8 eps,a(m,n),ra(*),w(17*m+70) --c --c --c Extract from the array w initialized by routine idd_frmi --c the greatest integer less than or equal to m that is --c a positive integer power of two. --c -- n2 = w(2) --c --c --c Allocate memory in ra. --c -- lra = 0 --c -- ira = lra+1 -- lra2 = n2*n -- lra = lra+lra2 --c -- irat = lra+1 -- lrat = n*(n2+1) -- lra = lra+lrat --c -- iscal = lra+1 -- lscal = n2+1 -- lra = lra+lscal --c -- call idd_estrank0(eps,m,n,a,w,n2,krank,ra(ira),ra(irat), -- 1 ra(iscal)) --c --c -- return -- end --c --c --c --c -- subroutine idd_estrank0(eps,m,n,a,w,n2,krank,ra,rat,scal) --c --c routine idd_estrank serves as a memory wrapper --c for the present routine. (Please see routine idd_estrank --c for further documentation.) --c -- implicit none -- integer m,n,n2,krank,ifrescal,k,nulls,j -- real*8 a(m,n),ra(n2,n),scal(n2+1),eps,residual, -- 1 w(17*m+70),rat(n,n2+1),ss,ssmax --c --c --c Apply the random matrix to every column of a, obtaining ra. --c -- do k = 1,n -- call idd_frm(m,n2,w,a(1,k),ra(1,k)) -- enddo ! k --c --c --c Compute the sum of squares of the entries in each column of ra --c and the maximum of all such sums. --c -- ssmax = 0 --c -- do k = 1,n --c -- ss = 0 -- do j = 1,m -- ss = ss+a(j,k)**2 -- enddo ! j --c -- if(ss .gt. ssmax) ssmax = ss --c -- enddo ! k --c --c --c Transpose ra to obtain rat. --c -- call idd_atransposer(n2,n,ra,rat) --c --c -- krank = 0 -- nulls = 0 --c --c --c Loop until nulls = 7, krank+nulls = n2, or krank+nulls = n. --c -- 1000 continue --c --c -- if(krank .gt. 0) then --c --c Apply the previous Householder transformations --c to rat(:,krank+1). --c -- ifrescal = 0 --c -- do k = 1,krank -- call idd_houseapp(n-k+1,rat(1,k),rat(k,krank+1), -- 1 ifrescal,scal(k),rat(k,krank+1)) -- enddo ! k --c -- endif ! krank .gt. 0 --c --c --c Compute the Householder vector associated --c with rat(krank+1:*,krank+1). --c -- call idd_house(n-krank,rat(krank+1,krank+1), -- 1 residual,rat(1,krank+1),scal(krank+1)) -- residual = abs(residual) --c --c -- krank = krank+1 -- if(residual .le. eps*sqrt(ssmax)) nulls = nulls+1 --c --c -- if(nulls .lt. 7 .and. krank+nulls .lt. n2 -- 1 .and. krank+nulls .lt. n) -- 2 goto 1000 --c --c -- if(nulls .lt. 7) krank = 0 --c --c -- return -- end --c --c --c --c -- subroutine idd_atransposer(m,n,a,at) --c --c transposes a to obtain at. --c --c input: --c m -- first dimension of a, and second dimension of at --c n -- second dimension of a, and first dimension of at --c a -- matrix to be transposed --c --c output: --c at -- transpose of a --c -- implicit none -- integer m,n,j,k -- real*8 a(m,n),at(n,m) --c --c -- do k = 1,n -- do j = 1,m --c -- at(k,j) = a(j,k) --c -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddp_asvd.f b/scipy/linalg/src/id_dist/src/iddp_asvd.f -deleted file mode 100644 -index a3dea4611..000000000 ---- a/scipy/linalg/src/id_dist/src/iddp_asvd.f -+++ /dev/null -@@ -1,180 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddp_asvd computes the SVD, to a specified precision, --c of an arbitrary matrix. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddp_asvd(lw,eps,m,n,a,winit,krank,iu,iv,is,w,ier) --c --c constructs a rank-krank SVD U Sigma V^T approximating a --c to precision eps, where U is an m x krank matrix whose --c columns are orthonormal, V is an n x krank matrix whose --c columns are orthonormal, and Sigma is a diagonal krank x krank --c matrix whose entries are all nonnegative. --c The entries of U are stored in w, starting at w(iu); --c the entries of V are stored in w, starting at w(iv). --c The diagonal entries of Sigma are stored in w, --c starting at w(is). This routine uses a randomized algorithm. --c --c input: --c lw -- maximum usable length (in real*8 elements) --c of the array w --c eps -- precision of the desired approximation --c m -- number of rows in a --c n -- number of columns in a --c a -- matrix to be approximated; the present routine does not --c alter a --c winit -- initialization array that has been constructed --c by routine idd_frmi --c --c output: --c krank -- rank of the SVD constructed --c iu -- index in w of the first entry of the matrix --c of orthonormal left singular vectors of a --c iv -- index in w of the first entry of the matrix --c of orthonormal right singular vectors of a --c is -- index in w of the first entry of the array --c of singular values of a --c w -- array containing the singular values and singular vectors --c of a; w doubles as a work array, and so must be at least --c max( (krank+1)*(3*m+5*n+1)+25*krank**2, (2*n+1)*(n2+1) ) --c real*8 elements long, where n2 is the greatest integer --c less than or equal to m, such that n2 is --c a positive integer power of two; krank is the rank output --c by this routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lw is too small; --c other nonzero values when idd_id2svd bombs --c --c _N.B._: w must be at least --c max( (krank+1)*(3*m+5*n+1)+25*krank^2, (2*n+1)*(n2+1) ) --c real*8 elements long, where n2 is the greatest integer --c less than or equal to m, such that n2 is --c a positive integer power of two; --c krank is the rank output by this routine. --c Also, the algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, -- 1 iwork,lwork,k,ier,lw2,iu,iv,is,iui,ivi,isi,lu,lv,ls -- real*8 eps,a(m,n),winit(17*m+70),w(*) --c --c --c Allocate memory in w. --c -- lw2 = 0 --c -- ilist = lw2+1 -- llist = n -- lw2 = lw2+llist --c -- iproj = lw2+1 --c --c --c ID a. --c -- call iddp_aid(eps,m,n,a,winit,krank,w(ilist),w(iproj)) --c --c -- if(krank .gt. 0) then --c --c --c Allocate more memory in w. --c -- lproj = krank*(n-krank) -- lw2 = lw2+lproj --c -- icol = lw2+1 -- lcol = m*krank -- lw2 = lw2+lcol --c -- iui = lw2+1 -- lu = m*krank -- lw2 = lw2+lu --c -- ivi = lw2+1 -- lv = n*krank -- lw2 = lw2+lv --c -- isi = lw2+1 -- ls = krank -- lw2 = lw2+ls --c -- iwork = lw2+1 -- lwork = (krank+1)*(m+3*n)+26*krank**2 -- lw2 = lw2+lwork --c --c -- if(lw .lt. lw2) then -- ier = -1000 -- return -- endif --c --c -- call iddp_asvd0(m,n,a,krank,w(ilist),w(iproj), -- 1 w(iui),w(ivi),w(isi),ier,w(icol),w(iwork)) -- if(ier .ne. 0) return --c --c -- iu = 1 -- iv = iu+lu -- is = iv+lv --c --c --c Copy the singular values and singular vectors --c into their proper locations. --c -- do k = 1,lu -- w(iu+k-1) = w(iui+k-1) -- enddo ! k --c -- do k = 1,lv -- w(iv+k-1) = w(ivi+k-1) -- enddo ! k --c -- do k = 1,ls -- w(is+k-1) = w(isi+k-1) -- enddo ! k --c --c -- endif ! krank .gt. 0 --c --c -- return -- end --c --c --c --c -- subroutine iddp_asvd0(m,n,a,krank,list,proj,u,v,s,ier, -- 1 col,work) --c --c routine iddp_asvd serves as a memory wrapper --c for the present routine (please see routine iddp_asvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier -- real*8 a(m,n),u(m,krank),v(n,krank), -- 1 s(krank),proj(krank,n-krank),col(m,krank), -- 2 work((krank+1)*(m+3*n)+26*krank**2) --c --c --c Collect together the columns of a indexed by list into col. --c -- call idd_copycols(m,n,a,krank,list,col) --c --c --c Convert the ID to an SVD. --c -- call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddp_rid.f b/scipy/linalg/src/id_dist/src/iddp_rid.f -deleted file mode 100644 -index 93b255f15..000000000 ---- a/scipy/linalg/src/id_dist/src/iddp_rid.f -+++ /dev/null -@@ -1,376 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddp_rid computes the ID, to a specified precision, --c of a matrix specified by a routine for applying its transpose --c to arbitrary vectors. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddp_rid(lproj,eps,m,n,matvect,p1,p2,p3,p4, -- 1 krank,list,proj,ier) --c --c computes the ID of a, i.e., lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon dimensioned epsilon(m,n-krank) --c such that the greatest singular value of epsilon --c <= the greatest singular value of a * eps. --c --c input: --c lproj -- maximum usable length (in real*8 elements) --c of the array proj --c eps -- precision to which the ID is to be computed --c m -- first dimension of a --c n -- second dimension of a --c matvect -- routine which applies the transpose --c of the matrix to be ID'd to an arbitrary vector; --c this routine must have a calling sequence --c of the form --c --c matvect(m,x,n,y,p1,p2,p3,p4), --c --c where m is the length of x, --c x is the vector to which the transpose --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the transposed matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvect --c p2 -- parameter to be passed to routine matvect --c p3 -- parameter to be passed to routine matvect --c p4 -- parameter to be passed to routine matvect --c --c output: --c krank -- numerical rank --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd; --c the present routine uses proj as a work array, too, so --c proj must be at least m+1 + 2*n*(krank+1) real*8 --c elements long, where krank is the rank output --c by the present routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lproj is too small --c --c _N.B._: The algorithm used by this routine is randomized. --c proj must be at least m+1 + 2*n*(krank+1) real*8 --c elements long, where krank is the rank output --c by the present routine. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,list(n),krank,lw,iwork,lwork,ira,kranki,lproj, -- 1 lra,ier,k -- real*8 eps,p1,p2,p3,p4,proj(*) -- external matvect --c --c -- ier = 0 --c --c --c Allocate memory in proj. --c -- lw = 0 --c -- iwork = lw+1 -- lwork = m+2*n+1 -- lw = lw+lwork --c -- ira = lw+1 --c --c --c Find the rank of a. --c -- lra = lproj-lwork -- call idd_findrank(lra,eps,m,n,matvect,p1,p2,p3,p4, -- 1 kranki,proj(ira),ier,proj(iwork)) -- if(ier .ne. 0) return --c --c -- if(lproj .lt. lwork+2*kranki*n) then -- ier = -1000 -- return -- endif --c --c --c Transpose ra. --c -- call idd_rtransposer(n,kranki,proj(ira),proj(ira+kranki*n)) --c --c --c Move the tranposed matrix to the beginning of proj. --c -- do k = 1,kranki*n -- proj(k) = proj(ira+kranki*n+k-1) -- enddo ! k --c --c --c ID the transposed matrix. --c -- call iddp_id(eps,kranki,n,proj,krank,list,proj(1+kranki*n)) --c --c -- return -- end --c --c --c --c -- subroutine idd_findrank(lra,eps,m,n,matvect,p1,p2,p3,p4, -- 1 krank,ra,ier,w) --c --c estimates the numerical rank krank of a matrix a to precision --c eps, where the routine matvect applies the transpose of a --c to an arbitrary vector. This routine applies the transpose of a --c to krank random vectors, and returns the resulting vectors --c as the columns of ra. --c --c input: --c lra -- maximum usable length (in real*8 elements) of array ra --c eps -- precision defining the numerical rank --c m -- first dimension of a --c n -- second dimension of a --c matvect -- routine which applies the transpose --c of the matrix whose rank is to be estimated --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvect(m,x,n,y,p1,p2,p3,p4), --c --c where m is the length of x, --c x is the vector to which the transpose --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the transposed matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvect --c p2 -- parameter to be passed to routine matvect --c p3 -- parameter to be passed to routine matvect --c p4 -- parameter to be passed to routine matvect --c --c output: --c krank -- estimate of the numerical rank of a --c ra -- product of the transpose of a and a matrix whose entries --c are pseudorandom realizations of i.i.d. random numbers, --c uniformly distributed on [0,1]; --c ra must be at least 2*n*krank real*8 elements long --c ier -- 0 when the routine terminates successfully; --c -1000 when lra is too small --c --c work: --c w -- must be at least m+2*n+1 real*8 elements long --c --c _N.B._: ra must be at least 2*n*krank real*8 elements long. --c Also, the algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,lw,krank,ix,lx,iy,ly,iscal,lscal,lra,ier -- real*8 eps,p1,p2,p3,p4,ra(n,*),w(m+2*n+1) -- external matvect --c --c -- lw = 0 --c -- ix = lw+1 -- lx = m -- lw = lw+lx --c -- iy = lw+1 -- ly = n -- lw = lw+ly --c -- iscal = lw+1 -- lscal = n+1 -- lw = lw+lscal --c --c -- call idd_findrank0(lra,eps,m,n,matvect,p1,p2,p3,p4, -- 1 krank,ra,ier,w(ix),w(iy),w(iscal)) --c --c -- return -- end --c --c --c --c -- subroutine idd_findrank0(lra,eps,m,n,matvect,p1,p2,p3,p4, -- 1 krank,ra,ier,x,y,scal) --c --c routine idd_findrank serves as a memory wrapper --c for the present routine. (Please see routine idd_findrank --c for further documentation.) --c -- implicit none -- integer m,n,krank,ifrescal,k,lra,ier -- real*8 x(m),ra(n,2,*),p1,p2,p3,p4,scal(n+1),y(n),eps,residual, -- 1 enorm -- external matvect --c --c -- ier = 0 --c --c -- krank = 0 --c --c --c Loop until the relative residual is greater than eps, --c or krank = m or krank = n. --c -- 1000 continue --c --c -- if(lra .lt. n*2*(krank+1)) then -- ier = -1000 -- return -- endif --c --c --c Apply the transpose of a to a random vector. --c -- call id_srand(m,x) -- call matvect(m,x,n,ra(1,1,krank+1),p1,p2,p3,p4) --c -- do k = 1,n -- y(k) = ra(k,1,krank+1) -- enddo ! k --c --c -- if(krank .eq. 0) then --c --c Compute the Euclidean norm of y. --c -- enorm = 0 --c -- do k = 1,n -- enorm = enorm + y(k)**2 -- enddo ! k --c -- enorm = sqrt(enorm) --c -- endif ! krank .eq. 0 --c --c -- if(krank .gt. 0) then --c --c Apply the previous Householder transformations to y. --c -- ifrescal = 0 --c -- do k = 1,krank -- call idd_houseapp(n-k+1,ra(1,2,k),y(k), -- 1 ifrescal,scal(k),y(k)) -- enddo ! k --c -- endif ! krank .gt. 0 --c --c --c Compute the Householder vector associated with y. --c -- call idd_house(n-krank,y(krank+1), -- 1 residual,ra(1,2,krank+1),scal(krank+1)) -- residual = abs(residual) --c --c -- krank = krank+1 --c --c -- if(residual .gt. eps*enorm -- 1 .and. krank .lt. m .and. krank .lt. n) -- 2 goto 1000 --c --c --c Delete the Householder vectors from the array ra. --c -- call idd_crunch(n,krank,ra) --c --c -- return -- end --c --c --c --c -- subroutine idd_crunch(n,l,a) --c --c removes every other block of n entries from a vector. --c --c input: --c n -- length of each block to remove --c l -- half of the total number of blocks --c a -- original array --c --c output: --c a -- array with every other block of n entries removed --c -- implicit none -- integer j,k,n,l -- real*8 a(n,2*l) --c --c -- do j = 2,l -- do k = 1,n --c -- a(k,j) = a(k,2*j-1) --c -- enddo ! k -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idd_rtransposer(m,n,a,at) --c --c transposes a to obtain at. --c --c input: --c m -- first dimension of a, and second dimension of at --c n -- second dimension of a, and first dimension of at --c a -- matrix to be transposed --c --c output: --c at -- transpose of a --c -- implicit none -- integer m,n,j,k -- real*8 a(m,n),at(n,m) --c --c -- do k = 1,n -- do j = 1,m --c -- at(k,j) = a(j,k) --c -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddp_rsvd.f b/scipy/linalg/src/id_dist/src/iddp_rsvd.f -deleted file mode 100644 -index 8af9ba04c..000000000 ---- a/scipy/linalg/src/id_dist/src/iddp_rsvd.f -+++ /dev/null -@@ -1,216 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddp_rsvd computes the SVD, to a specified precision, --c of a matrix specified by routines for applying the matrix --c and its transpose to arbitrary vectors. --c This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddp_rsvd(lw,eps,m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,iu,iv,is,w,ier) --c --c constructs a rank-krank SVD U Sigma V^T approximating a --c to precision eps, where matvect is a routine which applies a^T --c to an arbitrary vector, and matvec is a routine --c which applies a to an arbitrary vector; U is an m x krank --c matrix whose columns are orthonormal, V is an n x krank --c matrix whose columns are orthonormal, and Sigma is a diagonal --c krank x krank matrix whose entries are all nonnegative. --c The entries of U are stored in w, starting at w(iu); --c the entries of V are stored in w, starting at w(iv). --c The diagonal entries of Sigma are stored in w, --c starting at w(is). This routine uses a randomized algorithm. --c --c input: --c lw -- maximum usable length (in real*8 elements) --c of the array w --c eps -- precision of the desired approximation --c m -- number of rows in a --c n -- number of columns in a --c matvect -- routine which applies the transpose --c of the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvect(m,x,n,y,p1t,p2t,p3t,p4t), --c --c where m is the length of x, --c x is the vector to which the transpose --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the transposed matrix and x, --c and p1t, p2t, p3t, and p4t are user-specified --c parameters --c p1t -- parameter to be passed to routine matvect --c p2t -- parameter to be passed to routine matvect --c p3t -- parameter to be passed to routine matvect --c p4t -- parameter to be passed to routine matvect --c matvec -- routine which applies the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which the matrix is to be applied, --c m is the length of y, --c y is the product of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c --c output: --c krank -- rank of the SVD constructed --c iu -- index in w of the first entry of the matrix --c of orthonormal left singular vectors of a --c iv -- index in w of the first entry of the matrix --c of orthonormal right singular vectors of a --c is -- index in w of the first entry of the array --c of singular values of a --c w -- array containing the singular values and singular vectors --c of a; w doubles as a work array, and so must be at least --c (krank+1)*(3*m+5*n+1)+25*krank**2 real*8 elements long, --c where krank is the rank returned by the present routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lw is too small; --c other nonzero values when idd_id2svd bombs --c --c _N.B._: w must be at least (krank+1)*(3*m+5*n+1)+25*krank**2 --c real*8 elements long, where krank is the rank --c returned by the present routine. Also, the algorithm --c used by the present routine is randomized. --c -- implicit none -- integer m,n,krank,lw,lw2,ilist,llist,iproj,icol,lcol,lp, -- 1 iwork,lwork,ier,lproj,iu,iv,is,lu,lv,ls,iui,ivi,isi,k -- real*8 eps,p1t,p2t,p3t,p4t,p1,p2,p3,p4,w(*) -- external matvect,matvec --c --c --c Allocate some memory. --c -- lw2 = 0 --c -- ilist = lw2+1 -- llist = n -- lw2 = lw2+llist --c -- iproj = lw2+1 --c --c --c ID a. --c -- lp = lw-lw2 -- call iddp_rid(lp,eps,m,n,matvect,p1t,p2t,p3t,p4t,krank, -- 1 w(ilist),w(iproj),ier) -- if(ier .ne. 0) return --c --c -- if(krank .gt. 0) then --c --c --c Allocate more memory. --c -- lproj = krank*(n-krank) -- lw2 = lw2+lproj --c -- icol = lw2+1 -- lcol = m*krank -- lw2 = lw2+lcol --c -- iui = lw2+1 -- lu = m*krank -- lw2 = lw2+lu --c -- ivi = lw2+1 -- lv = n*krank -- lw2 = lw2+lv --c -- isi = lw2+1 -- ls = krank -- lw2 = lw2+ls --c -- iwork = lw2+1 -- lwork = (krank+1)*(m+3*n)+26*krank**2 -- lw2 = lw2+lwork --c --c -- if(lw .lt. lw2) then -- ier = -1000 -- return -- endif --c --c -- call iddp_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,w(iui),w(ivi), -- 2 w(isi),ier,w(ilist),w(iproj),w(icol), -- 3 w(iwork)) -- if(ier .ne. 0) return --c --c -- iu = 1 -- iv = iu+lu -- is = iv+lv --c --c --c Copy the singular values and singular vectors --c into their proper locations. --c -- do k = 1,lu -- w(iu+k-1) = w(iui+k-1) -- enddo ! k --c -- do k = 1,lv -- w(iv+k-1) = w(ivi+k-1) -- enddo ! k --c -- do k = 1,ls -- w(is+k-1) = w(isi+k-1) -- enddo ! k --c --c -- endif ! krank .gt. 0 --c --c -- return -- end --c --c --c --c -- subroutine iddp_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, -- 2 list,proj,col,work) --c --c routine iddp_rsvd serves as a memory wrapper --c for the present routine (please see routine iddp_rsvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier -- real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), -- 1 s(krank),proj(krank,n-krank),col(m*krank), -- 2 work((krank+1)*(m+3*n)+26*krank**2) -- external matvect,matvec --c --c --c Collect together the columns of a indexed by list into col. --c -- call idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work) --c --c --c Convert the ID to an SVD. --c -- call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddr_aid.f b/scipy/linalg/src/id_dist/src/iddr_aid.f -deleted file mode 100644 -index 2dc811148..000000000 ---- a/scipy/linalg/src/id_dist/src/iddr_aid.f -+++ /dev/null -@@ -1,208 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddr_aid computes the ID, to a specified rank, --c of an arbitrary matrix. This routine is randomized. --c --c routine iddr_aidi initializes routine iddr_aid. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddr_aid(m,n,a,krank,w,list,proj) --c --c computes the ID of the matrix a, i.e., lists in list --c the indices of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c min(m,n,krank) --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon, dimensioned epsilon(m,n-krank), --c whose norm is (hopefully) minimized by the pivoting procedure. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c a -- matrix to be ID'd; the present routine does not alter a --c krank -- rank of the ID to be constructed --c w -- initialization array that routine iddr_aidi --c has constructed --c --c output: --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd --c --c _N.B._: The algorithm used by this routine is randomized. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,krank,list(n),lw,ir,lr,lw2,iw -- real*8 a(m,n),proj(krank*(n-krank)),w((2*krank+17)*n+27*m+100) --c --c --c Allocate memory in w. --c -- lw = 0 --c -- iw = lw+1 -- lw2 = 27*m+100+n -- lw = lw+lw2 --c -- ir = lw+1 -- lr = (krank+8)*2*n -- lw = lw+lr --c --c -- call iddr_aid0(m,n,a,krank,w(iw),list,proj,w(ir)) --c --c -- return -- end --c --c --c --c -- subroutine iddr_aid0(m,n,a,krank,w,list,proj,r) --c --c routine iddr_aid serves as a memory wrapper --c for the present routine --c (see iddr_aid for further documentation). --c -- implicit none -- integer k,l,m,n2,n,krank,list(n),mn,lproj -- real*8 a(m,n),r(krank+8,2*n),proj(krank,n-krank), -- 1 w(27*m+100+n) --c --c Please note that the second dimension of r is 2*n --c (instead of n) so that if krank+8 >= m/2, then --c we can copy the whole of a into r. --c --c --c Retrieve the number of random test vectors --c and the greatest integer less than m that is --c a positive integer power of two. --c -- l = w(1) -- n2 = w(2) --c --c -- if(l .lt. n2 .and. l .le. m) then --c --c Apply the random matrix. --c -- do k = 1,n -- call idd_sfrm(l,m,n2,w(11),a(1,k),r(1,k)) -- enddo ! k --c --c ID r. --c -- call iddr_id(l,n,r,krank,list,w(26*m+101)) --c --c Retrieve proj from r. --c -- lproj = krank*(n-krank) -- call iddr_copydarr(lproj,r,proj) --c -- endif --c --c -- if(l .ge. n2 .or. l .gt. m) then --c --c ID a directly. --c -- mn = m*n -- call iddr_copydarr(mn,a,r) -- call iddr_id(m,n,r,krank,list,w(26*m+101)) --c --c Retrieve proj from r. --c -- lproj = krank*(n-krank) -- call iddr_copydarr(lproj,r,proj) --c -- endif --c --c -- return -- end --c --c --c --c -- subroutine iddr_copydarr(n,a,b) --c --c copies a into b. --c --c input: --c n -- length of a and b --c a -- array to copy into b --c --c output: --c b -- copy of a --c -- implicit none -- integer n,k -- real*8 a(n),b(n) --c --c -- do k = 1,n -- b(k) = a(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine iddr_aidi(m,n,krank,w) --c --c initializes the array w for using routine iddr_aid. --c --c input: --c m -- number of rows in the matrix to be ID'd --c n -- number of columns in the matrix to be ID'd --c krank -- rank of the ID to be constructed --c --c output: --c w -- initialization array for using routine iddr_aid --c -- implicit none -- integer m,n,krank,l,n2 -- real*8 w((2*krank+17)*n+27*m+100) --c --c --c Set the number of random test vectors to 8 more than the rank. --c -- l = krank+8 -- w(1) = l --c --c --c Initialize the rest of the array w. --c -- n2 = 0 -- if(l .le. m) call idd_sfrmi(l,m,n2,w(11)) -- w(2) = n2 --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddr_asvd.f b/scipy/linalg/src/id_dist/src/iddr_asvd.f -deleted file mode 100644 -index 9641f0cd6..000000000 ---- a/scipy/linalg/src/id_dist/src/iddr_asvd.f -+++ /dev/null -@@ -1,114 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddr_aid computes the SVD, to a specified rank, --c of an arbitrary matrix. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddr_asvd(m,n,a,krank,w,u,v,s,ier) --c --c constructs a rank-krank SVD u diag(s) v^T approximating a, --c where u is an m x krank matrix whose columns are orthonormal, --c v is an n x krank matrix whose columns are orthonormal, --c and diag(s) is a diagonal krank x krank matrix whose entries --c are all nonnegative. This routine uses a randomized algorithm. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c a -- matrix to be decomposed; the present routine does not --c alter a --c krank -- rank of the SVD being constructed --c w -- initialization array that routine iddr_aidi --c has constructed (for use in the present routine, w must --c be at least (2*krank+28)*m+(6*krank+21)*n+25*krank**2+100 --c real*8 elements long) --c --c output: --c u -- matrix of orthonormal left singular vectors of a --c v -- matrix of orthonormal right singular vectors of a --c s -- array of singular values of a --c ier -- 0 when the routine terminates successfully; --c nonzero otherwise --c --c _N.B._: The algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, -- 1 iwork,lwork,iwinit,lwinit,ier -- real*8 a(m,n),u(m,krank),v(n,krank),s(krank), -- 1 w((2*krank+28)*m+(6*krank+21)*n+25*krank**2+100) --c --c --c Allocate memory in w. --c -- lw = 0 --c -- iwinit = lw+1 -- lwinit = (2*krank+17)*n+27*m+100 -- lw = lw+lwinit --c -- ilist = lw+1 -- llist = n -- lw = lw+llist --c -- iproj = lw+1 -- lproj = krank*(n-krank) -- lw = lw+lproj --c -- icol = lw+1 -- lcol = m*krank -- lw = lw+lcol --c -- iwork = lw+1 -- lwork = (krank+1)*(m+3*n)+26*krank**2 -- lw = lw+lwork --c --c -- call iddr_asvd0(m,n,a,krank,w(iwinit),u,v,s,ier, -- 1 w(ilist),w(iproj),w(icol),w(iwork)) --c --c -- return -- end --c --c --c --c -- subroutine iddr_asvd0(m,n,a,krank,winit,u,v,s,ier, -- 1 list,proj,col,work) --c --c routine iddr_asvd serves as a memory wrapper --c for the present routine (please see routine iddr_asvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier -- real*8 a(m,n),u(m,krank),v(n,krank),s(krank), -- 1 proj(krank,n-krank),col(m*krank), -- 2 winit((2*krank+17)*n+27*m+100), -- 3 work((krank+1)*(m+3*n)+26*krank**2) --c --c --c ID a. --c -- call iddr_aid(m,n,a,krank,winit,list,proj) --c --c --c Collect together the columns of a indexed by list into col. --c -- call idd_copycols(m,n,a,krank,list,col) --c --c --c Convert the ID to an SVD. --c -- call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddr_rid.f b/scipy/linalg/src/id_dist/src/iddr_rid.f -deleted file mode 100644 -index eb96c145a..000000000 ---- a/scipy/linalg/src/id_dist/src/iddr_rid.f -+++ /dev/null -@@ -1,155 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddr_rid computes the ID, to a specified rank, --c of a matrix specified by a routine for applying its transpose --c to arbitrary vectors. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddr_rid(m,n,matvect,p1,p2,p3,p4,krank,list,proj) --c --c computes the ID of a matrix "a" specified by --c the routine matvect -- matvect must apply the transpose --c of the matrix being ID'd to an arbitrary vector -- --c i.e., the present routine lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c min(m,n,krank) --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon, dimensioned epsilon(m,n-krank), --c whose norm is (hopefully) minimized by the pivoting procedure. --c --c input: --c m -- number of rows in the matrix to be ID'd --c n -- number of columns in the matrix to be ID'd --c matvect -- routine which applies the transpose --c of the matrix to be ID'd to an arbitrary vector; --c this routine must have a calling sequence --c of the form --c --c matvect(m,x,n,y,p1,p2,p3,p4), --c --c where m is the length of x, --c x is the vector to which the transpose --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the transposed matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvect --c p2 -- parameter to be passed to routine matvect --c p3 -- parameter to be passed to routine matvect --c p4 -- parameter to be passed to routine matvect --c krank -- rank of the ID to be constructed --c --c output: --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd; --c proj doubles as a work array in the present routine, so --c proj must be at least m+(krank+3)*n real*8 elements --c long --c --c _N.B._: The algorithm used by this routine is randomized. --c proj must be at least m+(krank+3)*n real*8 elements --c long. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr -- real*8 p1,p2,p3,p4,proj(m+(krank+3)*n) -- external matvect --c --c --c Allocate memory in w. --c -- lw = 0 --c -- ir = lw+1 -- lr = (krank+2)*n -- lw = lw+lr --c -- ix = lw+1 -- lx = m -- lw = lw+lx --c -- iy = lw+1 -- ly = n -- lw = lw+ly --c --c -- call iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank, -- 1 list,proj(ir),proj(ix),proj(iy)) --c --c -- return -- end --c --c --c --c -- subroutine iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank, -- 1 list,r,x,y) --c --c routine iddr_ridall serves as a memory wrapper --c for the present routine --c (see iddr_ridall for further documentation). --c -- implicit none -- integer j,k,l,m,n,krank,list(n) -- real*8 x(m),y(n),p1,p2,p3,p4,r(krank+2,n) -- external matvect --c --c --c Set the number of random test vectors to 2 more than the rank. --c -- l = krank+2 --c --c Apply the transpose of the original matrix to l random vectors. --c -- do j = 1,l --c --c Generate a random vector. --c -- call id_srand(m,x) --c --c Apply the transpose of the matrix to x, obtaining y. --c -- call matvect(m,x,n,y,p1,p2,p3,p4) --c --c Copy y into row j of r. --c -- do k = 1,n -- r(j,k) = y(k) -- enddo ! k --c -- enddo ! j --c --c --c ID r. --c -- call iddr_id(l,n,r,krank,list,y) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/iddr_rsvd.f b/scipy/linalg/src/id_dist/src/iddr_rsvd.f -deleted file mode 100644 -index 000ce8693..000000000 ---- a/scipy/linalg/src/id_dist/src/iddr_rsvd.f -+++ /dev/null -@@ -1,157 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine iddr_rsvd computes the SVD, to a specified rank, --c of a matrix specified by routines for applying the matrix --c and its transpose to arbitrary vectors. --c This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine iddr_rsvd(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier,w) --c --c constructs a rank-krank SVD u diag(s) v^T approximating a, --c where matvect is a routine which applies a^T --c to an arbitrary vector, and matvec is a routine --c which applies a to an arbitrary vector; --c u is an m x krank matrix whose columns are orthonormal, --c v is an n x krank matrix whose columns are orthonormal, --c and diag(s) is a diagonal krank x krank matrix whose entries --c are all nonnegative. This routine uses a randomized algorithm. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c matvect -- routine which applies the transpose --c of the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvect(m,x,n,y,p1t,p2t,p3t,p4t), --c --c where m is the length of x, --c x is the vector to which the transpose --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the transposed matrix and x, --c and p1t, p2t, p3t, and p4t are user-specified --c parameters --c p1t -- parameter to be passed to routine matvect --c p2t -- parameter to be passed to routine matvect --c p3t -- parameter to be passed to routine matvect --c p4t -- parameter to be passed to routine matvect --c matvec -- routine which applies the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which the matrix is to be applied, --c m is the length of y, --c y is the product of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c krank -- rank of the SVD being constructed --c --c output: --c u -- matrix of orthonormal left singular vectors of a --c v -- matrix of orthonormal right singular vectors of a --c s -- array of singular values of a --c ier -- 0 when the routine terminates successfully; --c nonzero otherwise --c --c work: --c w -- must be at least (krank+1)*(2*m+4*n)+25*krank**2 --c real*8 elements long --c --c _N.B._: The algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, -- 1 iwork,lwork,ier -- real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), -- 1 s(krank),w((krank+1)*(2*m+4*n)+25*krank**2) -- external matvect,matvec --c --c --c Allocate memory in w. --c -- lw = 0 --c -- ilist = lw+1 -- llist = n -- lw = lw+llist --c -- iproj = lw+1 -- lproj = krank*(n-krank) -- lw = lw+lproj --c -- icol = lw+1 -- lcol = m*krank -- lw = lw+lcol --c -- iwork = lw+1 -- lwork = (krank+1)*(m+3*n)+26*krank**2 -- lw = lw+lwork --c --c -- call iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, -- 2 w(ilist),w(iproj),w(icol),w(iwork)) --c --c -- return -- end --c --c --c --c -- subroutine iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, -- 2 list,proj,col,work) --c --c routine iddr_rsvd serves as a memory wrapper --c for the present routine (please see routine iddr_rsvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier,k -- real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), -- 1 s(krank),proj(krank*(n-krank)),col(m*krank), -- 2 work((krank+1)*(m+3*n)+26*krank**2) -- external matvect,matvec --c --c --c ID a. --c -- call iddr_rid(m,n,matvect,p1t,p2t,p3t,p4t,krank,list,work) --c --c --c Retrieve proj from work. --c -- do k = 1,krank*(n-krank) -- proj(k) = work(k) -- enddo ! k --c --c --c Collect together the columns of a indexed by list into col. --c -- call idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work) --c --c --c Convert the ID to an SVD. --c -- call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_frm.f b/scipy/linalg/src/id_dist/src/idz_frm.f -deleted file mode 100644 -index 93c4d8ec7..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_frm.f -+++ /dev/null -@@ -1,419 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idz_frm transforms a vector via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c --c routine idz_sfrm transforms a vector into a vector --c of specified length via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c --c routine idz_frmi initializes routine idz_frm. --c --c routine idz_sfrmi initializes routine idz_sfrm. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idz_frm(m,n,w,x,y) --c --c transforms x into y via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c In contrast to routine idz_sfrm, the present routine works best --c when the length of the transformed vector is the integer n --c output by routine idz_frmi, or when the length --c is not specified, but instead determined a posteriori --c using the output of the present routine. The transformed vector --c output by the present routine is randomly permuted. --c --c input: --c m -- length of x --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m, as obtained --c from the routine idz_frmi; n is the length of y --c w -- initialization array constructed by routine idz_frmi --c x -- vector to be transformed --c --c output: --c y -- transform of x --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,iw,n,k -- complex*16 w(17*m+70),x(m),y(n) --c --c --c Apply Rokhlin's random transformation to x, obtaining --c w(16*m+71 : 17*m+70). --c -- iw = w(3+m+n) -- call idz_random_transf(x,w(16*m+70+1),w(iw)) --c --c --c Subselect from w(16*m+71 : 17*m+70) to obtain y. --c -- call idz_subselect(n,w(3),m,w(16*m+70+1),y) --c --c --c Copy y into w(16*m+71 : 16*m+n+70). --c -- do k = 1,n -- w(16*m+70+k) = y(k) -- enddo ! k --c --c --c Fourier transform w(16*m+71 : 16*m+n+70). --c -- call zfftf(n,w(16*m+70+1),w(4+m+n)) --c --c --c Permute w(16*m+71 : 16*m+n+70) to obtain y. --c -- call idz_permute(n,w(3+m),w(16*m+70+1),y) --c --c -- return -- end --c --c --c --c -- subroutine idz_sfrm(l,m,n,w,x,y) --c --c transforms x into y via a composition --c of Rokhlin's random transform, random subselection, and an FFT. --c In contrast to routine idz_frm, the present routine works best --c when the length l of the transformed vector is known a priori. --c --c input: --c l -- length of y; l must be less than or equal to n --c m -- length of x --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m, as obtained --c from the routine idz_frmi --c w -- initialization array constructed by routine idz_sfrmi --c x -- vector to be transformed --c --c output: --c y -- transform of x --c --c _N.B._: l must be less than or equal to n. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,iw,n,l -- complex*16 w(21*m+70),x(m),y(l) --c --c --c Apply Rokhlin's random transformation to x, obtaining --c w(19*m+71 : 20*m+70). --c -- iw = w(4+m+l) -- call idz_random_transf(x,w(19*m+70+1),w(iw)) --c --c --c Subselect from w(19*m+71 : 20*m+70) to obtain --c w(20*m+71 : 20*m+n+70). --c -- call idz_subselect(n,w(4),m,w(19*m+70+1),w(20*m+70+1)) --c --c --c Fourier transform w(20*m+71 : 20*m+n+70). --c -- call idz_sfft(l,w(4+m),n,w(5+m+l),w(20*m+70+1)) --c --c --c Copy the desired entries from w(20*m+71 : 20*m+n+70) --c to y. --c -- call idz_subselect(l,w(4+m),n,w(20*m+70+1),y) --c --c -- return -- end --c --c --c --c -- subroutine idz_permute(n,ind,x,y) --c --c copy the entries of x into y, rearranged according --c to the permutation specified by ind. --c --c input: --c n -- length of ind, x, and y --c ind -- permutation of n objects --c x -- vector to be permuted --c --c output: --c y -- permutation of x --c -- implicit none -- integer n,ind(n),k -- complex*16 x(n),y(n) --c --c -- do k = 1,n -- y(k) = x(ind(k)) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_subselect(n,ind,m,x,y) --c --c copies into y the entries of x indicated by ind. --c --c input: --c n -- number of entries of x to copy into y --c ind -- indices of the entries in x to copy into y --c m -- length of x --c x -- vector whose entries are to be copied --c --c output: --c y -- collection of entries of x specified by ind --c -- implicit none -- integer n,ind(n),m,k -- complex*16 x(m),y(n) --c --c -- do k = 1,n -- y(k) = x(ind(k)) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_frmi(m,n,w) --c --c initializes data for the routine idz_frm. --c --c input: --c m -- length of the vector to be transformed --c --c output: --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m --c w -- initialization array to be used by routine idz_frm --c --c --c glossary for the fully initialized w: --c --c w(1) = m --c w(2) = n --c w(3:2+m) stores a permutation of m objects --c w(3+m:2+m+n) stores a permutation of n objects --c w(3+m+n) = address in w of the initialization array --c for idz_random_transf --c w(4+m+n:int(w(3+m+n))-1) stores the initialization array --c for zfft --c w(int(w(3+m+n)):16*m+70) stores the initialization array --c for idz_random_transf --c --c --c _N.B._: n is an output of the present routine; --c this routine changes n. --c --c -- implicit none -- integer m,n,l,nsteps,keep,lw,ia -- complex*16 w(17*m+70) --c --c --c Find the greatest integer less than or equal to m --c which is a power of two. --c -- call idz_poweroftwo(m,l,n) --c --c --c Store m and n in w. --c -- w(1) = m -- w(2) = n --c --c --c Store random permutations of m and n objects in w. --c -- call id_randperm(m,w(3)) -- call id_randperm(n,w(3+m)) --c --c --c Store the address within w of the idz_random_transf_init --c initialization data. --c -- ia = 4+m+n+2*n+15 -- w(3+m+n) = ia --c --c --c Store the initialization data for zfft in w. --c -- call zffti(n,w(4+m+n)) --c --c --c Store the initialization data for idz_random_transf_init in w. --c -- nsteps = 3 -- call idz_random_transf_init(nsteps,m,w(ia),keep) --c --c --c Calculate the total number of elements used in w. --c -- lw = 3+m+n+2*n+15 + 3*nsteps*m+2*m+m/4+50 --c -- if(16*m+70 .lt. lw) then -- call prinf('lw = *',lw,1) -- call prinf('16m+70 = *',16*m+70,1) -- stop -- endif --c --c -- return -- end --c --c --c --c -- subroutine idz_sfrmi(l,m,n,w) --c --c initializes data for the routine idz_sfrm. --c --c input: --c l -- length of the transformed (output) vector --c m -- length of the vector to be transformed --c --c output: --c n -- greatest integer expressible as a positive integer power --c of 2 that is less than or equal to m --c w -- initialization array to be used by routine idz_sfrm --c --c --c glossary for the fully initialized w: --c --c w(1) = m --c w(2) = n --c w(3) is unused --c w(4:3+m) stores a permutation of m objects --c w(4+m:3+m+l) stores the indices of the l outputs which idz_sfft --c calculates --c w(4+m+l) = address in w of the initialization array --c for idz_random_transf --c w(5+m+l:int(w(4+m+l))-1) stores the initialization array --c for idz_sfft --c w(int(w(4+m+l)):19*m+70) stores the initialization array --c for idz_random_transf --c --c --c _N.B._: n is an output of the present routine; --c this routine changes n. --c --c -- implicit none -- integer l,m,n,idummy,nsteps,keep,lw,ia -- complex*16 w(21*m+70) --c --c --c Find the greatest integer less than or equal to m --c which is a power of two. --c -- call idz_poweroftwo(m,idummy,n) --c --c --c Store m and n in w. --c -- w(1) = m -- w(2) = n -- w(3) = 0 --c --c --c Store random permutations of m and n objects in w. --c -- call id_randperm(m,w(4)) -- call id_randperm(n,w(4+m)) --c --c --c Store the address within w of the idz_random_transf_init --c initialization data. --c -- ia = 5+m+l+2*l+15+3*n -- w(4+m+l) = ia --c --c --c Store the initialization data for idz_sfft in w. --c -- call idz_sffti(l,w(4+m),n,w(5+m+l)) --c --c --c Store the initialization data for idz_random_transf_init in w. --c -- nsteps = 3 -- call idz_random_transf_init(nsteps,m,w(ia),keep) --c --c --c Calculate the total number of elements used in w. --c -- lw = 4+m+l+2*l+15+3*n + 3*nsteps*m+2*m+m/4+50 --c -- if(19*m+70 .lt. lw) then -- call prinf('lw = *',lw,1) -- call prinf('19m+70 = *',19*m+70,1) -- stop -- endif --c --c -- return -- end --c --c --c --c -- subroutine idz_poweroftwo(m,l,n) --c --c computes l = floor(log_2(m)) and n = 2**l. --c --c input: --c m -- integer whose log_2 is to be taken --c --c output: --c l -- floor(log_2(m)) --c n -- 2**l --c -- implicit none -- integer l,m,n --c --c -- l = 0 -- n = 1 --c -- 1000 continue -- l = l+1 -- n = n*2 -- if(n .le. m) goto 1000 --c -- l = l-1 -- n = n/2 --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_house.f b/scipy/linalg/src/id_dist/src/idz_house.f -deleted file mode 100644 -index 93db06e6d..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_house.f -+++ /dev/null -@@ -1,298 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idz_house calculates the vector and scalar --c needed to apply the Householder transformation reflecting --c a given vector into its first component. --c --c routine idz_houseapp applies a Householder matrix to a vector. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idz_houseapp(n,vn,u,ifrescal,scal,v) --c --c applies the Householder matrix --c identity_matrix - scal * vn * adjoint(vn) --c to the vector u, yielding the vector v; --c --c scal = 2/(1 + |vn(2)|^2 + ... + |vn(n)|^2) --c when vn(2), ..., vn(n) don't all vanish; --c --c scal = 0 --c when vn(2), ..., vn(n) do all vanish --c (including when n = 1). --c --c input: --c n -- size of vn, u, and v, though the indexing on vn goes --c from 2 to n --c vn -- components 2 to n of the Householder vector vn; --c vn(1) is assumed to be 1 --c u -- vector to be transformed --c ifrescal -- set to 1 to recompute scal from vn(2), ..., vn(n); --c set to 0 to use scal as input --c scal -- see the entry for ifrescal in the decription --c of the input --c --c output: --c scal -- see the entry for ifrescal in the decription --c of the input --c v -- result of applying the Householder matrix to u; --c it's O.K. to have v be the same as u --c in order to apply the matrix to the vector in place --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- save -- integer n,k,ifrescal -- real*8 scal,sum -- complex*16 vn(2:*),u(n),v(n),fact --c --c --c Get out of this routine if n = 1. --c -- if(n .eq. 1) then -- v(1) = u(1) -- return -- endif --c --c -- if(ifrescal .eq. 1) then --c --c --c Calculate |vn(2)|^2 + ... + |vn(n)|^2. --c -- sum = 0 -- do k = 2,n -- sum = sum+vn(k)*conjg(vn(k)) -- enddo ! k --c --c --c Calculate scal. --c -- if(sum .eq. 0) scal = 0 -- if(sum .ne. 0) scal = 2/(1+sum) --c --c -- endif --c --c --c Calculate fact = scal * adjoint(vn) * u. --c -- fact = u(1) --c -- do k = 2,n -- fact = fact+conjg(vn(k))*u(k) -- enddo ! k --c -- fact = fact*scal --c --c --c Subtract fact*vn from u, yielding v. --c -- v(1) = u(1) - fact --c -- do k = 2,n -- v(k) = u(k) - fact*vn(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_house(n,x,css,vn,scal) --c --c constructs the vector vn with vn(1) = 1, --c and the scalar scal, such that the obviously self-adjoint --c H := identity_matrix - scal * vn * adjoint(vn) is unitary, --c the absolute value of the first entry of Hx --c is the root-sum-square of the entries of x, --c and all other entries of Hx are zero --c (H is the Householder matrix corresponding to x). --c --c input: --c n -- size of x and vn, though the indexing on vn goes --c from 2 to n --c x -- vector to reflect into its first component --c --c output: --c css -- root-sum-square of the entries of x * the phase of x(1) --c vn -- entries 2 to n of the Householder vector vn; --c vn(1) is assumed to be 1 --c scal -- scalar multiplying vn * adjoint(vn); --c --c scal = 2/(1 + |vn(2)|^2 + ... + |vn(n)|^2) --c when vn(2), ..., vn(n) don't all vanish; --c --c scal = 0 --c when vn(2), ..., vn(n) do all vanish --c (including when n = 1) --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- save -- integer n,k -- real*8 scal,test,rss,sum -- complex*16 x(n),v1,vn(2:*),x1,phase,css --c --c -- x1 = x(1) --c --c --c Get out of this routine if n = 1. --c -- if(n .eq. 1) then -- css = x1 -- scal = 0 -- return -- endif --c --c --c Calculate |x(2)|^2 + ... |x(n)|^2 --c and the root-sum-square value of the entries in x. --c --c -- sum = 0 -- do k = 2,n -- sum = sum+x(k)*conjg(x(k)) -- enddo ! k --c --c --c Get out of this routine if sum = 0; --c flag this case as such by setting v(2), ..., v(n) all to 0. --c -- if(sum .eq. 0) then --c -- css = x1 -- do k = 2,n -- vn(k) = 0 -- enddo ! k -- scal = 0 --c -- return --c -- endif --c --c -- rss = x1*conjg(x1) + sum -- rss = sqrt(rss) --c --c --c Determine the first component v1 --c of the unnormalized Householder vector --c v = x - phase(x1) * rss * (1 0 0 ... 0 0)^T. --c -- if(x1 .eq. 0) phase = 1 -- if(x1 .ne. 0) phase = x1/abs(x1) -- test = conjg(phase) * x1 -- css = phase*rss --c --c If test <= 0, then form x1-phase*rss directly, --c since that expression cannot involve any cancellation. --c -- if(test .le. 0) v1 = x1-phase*rss --c --c If test > 0, then use the fact that --c x1-phase*rss = -phase*sum / ((phase)^* * x1 + rss), --c in order to avoid potential cancellation. --c -- if(test .gt. 0) v1 = -phase*sum / (conjg(phase)*x1+rss) --c --c --c Compute the vector vn and the scalar scal such that vn(1) = 1 --c in the Householder transformation --c identity_matrix - scal * vn * adjoint(vn). --c -- do k = 2,n -- vn(k) = x(k)/v1 -- enddo ! k --c --c scal = 2 --c / ( |vn(1)|^2 + |vn(2)|^2 + ... + |vn(n)|^2 ) --c --c = 2 --c / ( 1 + |vn(2)|^2 + ... + |vn(n)|^2 ) --c --c = 2*|v(1)|^2 --c / ( |v(1)|^2 + |v(1)*vn(2)|^2 + ... + |v(1)*vn(n)|^2 ) --c --c = 2*|v(1)|^2 --c / ( |v(1)|^2 + (|v(2)|^2 + ... + |v(n)|^2) ) --c -- scal = 2*v1*conjg(v1) / (v1*conjg(v1)+sum) --c --c -- rss = phase*rss --c --c -- return -- end --c --c --c --c -- subroutine idz_housemat(n,vn,scal,h) --c --c fills h with the Householder matrix --c identity_matrix - scal * vn * adjoint(vn). --c --c input: --c n -- size of vn and h, though the indexing of vn goes --c from 2 to n --c vn -- entries 2 to n of the vector vn; --c vn(1) is assumed to be 1 --c scal -- scalar multiplying vn * adjoint(vn) --c --c output: --c h -- identity_matrix - scal * vn * adjoint(vn) --c -- implicit none -- save -- integer n,j,k -- real*8 scal -- complex*16 vn(2:*),h(n,n),factor1,factor2 --c --c --c Fill h with the identity matrix. --c -- do j = 1,n -- do k = 1,n --c -- if(j .eq. k) h(k,j) = 1 -- if(j .ne. k) h(k,j) = 0 --c -- enddo ! k -- enddo ! j --c --c --c Subtract from h the matrix scal*vn*adjoint(vn). --c -- do j = 1,n -- do k = 1,n --c -- if(j .eq. 1) factor1 = 1 -- if(j .ne. 1) factor1 = vn(j) --c -- if(k .eq. 1) factor2 = 1 -- if(k .ne. 1) factor2 = conjg(vn(k)) --c -- h(k,j) = h(k,j) - scal*factor1*factor2 --c -- enddo ! k -- enddo ! j --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_id.f b/scipy/linalg/src/id_dist/src/idz_id.f -deleted file mode 100644 -index 7a80243ff..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_id.f -+++ /dev/null -@@ -1,566 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzp_id computes the ID of a matrix, --c to a specified precision. --c --c routine idzr_id computes the ID of a matrix, --c to a specified rank. --c --c routine idz_reconid reconstructs a matrix from its ID. --c --c routine idz_copycols collects together selected columns --c of a matrix. --c --c routine idz_getcols collects together selected columns --c of a matrix specified by a routine for applying the matrix --c to arbitrary vectors. --c --c routine idz_reconint constructs p in the ID a = b p, --c where the columns of b are a subset of the columns of a, --c and p is the projection coefficient matrix, --c given list, krank, and proj output by routines idzr_id --c or idzp_id. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzp_id(eps,m,n,a,krank,list,rnorms) --c --c computes the ID of a, i.e., lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon dimensioned epsilon(m,n-krank) --c such that the greatest singular value of epsilon --c <= the greatest singular value of a * eps. --c The present routine stores the krank x (n-krank) matrix proj --c in the memory initially occupied by a. --c --c input: --c eps -- relative precision of the resulting ID --c m -- first dimension of a --c n -- second dimension of a, as well as the dimension required --c of list --c a -- matrix to be ID'd --c --c output: --c a -- the first krank*(n-krank) elements of a constitute --c the krank x (n-krank) interpolation matrix proj --c krank -- numerical rank --c list -- list of the indices of the krank columns of a --c through which the other columns of a are expressed; --c also, list describes the permutation of proj --c required to reconstruct a as indicated in (*) above --c rnorms -- absolute values of the entries on the diagonal --c of the triangular matrix used to compute the ID --c (these may be used to check the stability of the ID) --c --c _N.B._: This routine changes a. --c --c reference: --c Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of --c low-rank matrices," SIAM Journal on Scientific Computing, --c 26 (4): 1389-1404, 2005. --c -- implicit none -- integer m,n,krank,k,list(n),iswap -- real*8 eps,rnorms(n) -- complex*16 a(m,n) --c --c --c QR decompose a. --c -- call idzp_qrpiv(eps,m,n,a,krank,list,rnorms) --c --c --c Build the list of columns chosen in a --c by multiplying together the permutations in list, --c with the permutation swapping 1 and list(1) taken rightmost --c in the product, that swapping 2 and list(2) taken next --c rightmost, ..., that swapping krank and list(krank) taken --c leftmost. --c -- do k = 1,n -- rnorms(k) = k -- enddo ! k --c -- if(krank .gt. 0) then -- do k = 1,krank --c --c Swap rnorms(k) and rnorms(list(k)). --c -- iswap = rnorms(k) -- rnorms(k) = rnorms(list(k)) -- rnorms(list(k)) = iswap --c -- enddo ! k -- endif --c -- do k = 1,n -- list(k) = rnorms(k) -- enddo ! k --c --c --c Fill rnorms for the output. --c -- if(krank .gt. 0) then --c -- do k = 1,krank -- rnorms(k) = a(k,k) -- enddo ! k --c -- endif --c --c --c Backsolve for proj, storing it at the beginning of a. --c -- if(krank .gt. 0) then -- call idz_lssolve(m,n,a,krank) -- endif --c --c -- return -- end --c --c --c --c -- subroutine idzr_id(m,n,a,krank,list,rnorms) --c --c computes the ID of a, i.e., lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon, dimensioned epsilon(m,n-krank), --c whose norm is (hopefully) minimized by the pivoting procedure. --c The present routine stores the krank x (n-krank) matrix proj --c in the memory initially occupied by a. --c --c input: --c m -- first dimension of a --c n -- second dimension of a, as well as the dimension required --c of list --c a -- matrix to be ID'd --c krank -- desired rank of the output matrix --c (please note that if krank > m or krank > n, --c then the rank of the output matrix will be --c less than krank) --c --c output: --c a -- the first krank*(n-krank) elements of a constitute --c the krank x (n-krank) interpolation matrix proj --c list -- list of the indices of the krank columns of a --c through which the other columns of a are expressed; --c also, list describes the permutation of proj --c required to reconstruct a as indicated in (*) above --c rnorms -- absolute values of the entries on the diagonal --c of the triangular matrix used to compute the ID --c (these may be used to check the stability of the ID) --c --c _N.B._: This routine changes a. --c --c reference: --c Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of --c low-rank matrices," SIAM Journal on Scientific Computing, --c 26 (4): 1389-1404, 2005. --c -- implicit none -- integer m,n,krank,j,k,list(n),iswap -- real*8 rnorms(n),ss -- complex*16 a(m,n) --c --c --c QR decompose a. --c -- call idzr_qrpiv(m,n,a,krank,list,rnorms) --c --c --c Build the list of columns chosen in a --c by multiplying together the permutations in list, --c with the permutation swapping 1 and list(1) taken rightmost --c in the product, that swapping 2 and list(2) taken next --c rightmost, ..., that swapping krank and list(krank) taken --c leftmost. --c -- do k = 1,n -- rnorms(k) = k -- enddo ! k --c -- if(krank .gt. 0) then -- do k = 1,krank --c --c Swap rnorms(k) and rnorms(list(k)). --c -- iswap = rnorms(k) -- rnorms(k) = rnorms(list(k)) -- rnorms(list(k)) = iswap --c -- enddo ! k -- endif --c -- do k = 1,n -- list(k) = rnorms(k) -- enddo ! k --c --c --c Fill rnorms for the output. --c -- ss = 0 --c -- do k = 1,krank -- rnorms(k) = a(k,k) -- ss = ss + rnorms(k)**2 -- enddo ! k --c --c --c Backsolve for proj, storing it at the beginning of a. --c -- if(krank .gt. 0 .and. ss .gt. 0) then -- call idz_lssolve(m,n,a,krank) -- endif --c -- if(ss .eq. 0) then --c -- do k = 1,n -- do j = 1,m --c -- a(j,k) = 0 --c -- enddo ! j -- enddo ! k --c -- endif --c --c -- return -- end --c --c --c --c -- subroutine idz_reconid(m,krank,col,n,list,proj,approx) --c --c reconstructs the matrix that the routine idzp_id --c or idzr_id has decomposed, using the columns col --c of the reconstructed matrix whose indices are listed in list, --c in addition to the interpolation matrix proj. --c --c input: --c m -- first dimension of cols and approx --c krank -- first dimension of cols and proj; also, --c n-krank is the second dimension of proj --c col -- columns of the matrix to be reconstructed --c n -- second dimension of approx; also, --c n-krank is the second dimension of proj --c list(k) -- index of col(1:m,k) in the reconstructed matrix --c when k <= krank; in general, list describes --c the permutation required for reconstruction --c via cols and proj --c proj -- interpolation matrix --c --c output: --c approx -- reconstructed matrix --c -- implicit none -- integer m,n,krank,j,k,l,list(n) -- complex*16 col(m,krank),proj(krank,n-krank),approx(m,n) --c --c -- do j = 1,m -- do k = 1,n --c -- approx(j,list(k)) = 0 --c --c Add in the contributions due to the identity matrix. --c -- if(k .le. krank) then -- approx(j,list(k)) = approx(j,list(k)) + col(j,k) -- endif --c --c Add in the contributions due to proj. --c -- if(k .gt. krank) then -- if(krank .gt. 0) then --c -- do l = 1,krank -- approx(j,list(k)) = approx(j,list(k)) -- 1 + col(j,l)*proj(l,k-krank) -- enddo ! l --c -- endif -- endif --c -- enddo ! k -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idz_lssolve(m,n,a,krank) --c --c backsolves for proj satisfying R_11 proj ~ R_12, --c where R_11 = a(1:krank,1:krank) --c and R_12 = a(1:krank,krank+1:n). --c This routine overwrites the beginning of a with proj. --c --c input: --c m -- first dimension of a --c n -- second dimension of a; also, --c n-krank is the second dimension of proj --c a -- trapezoidal input matrix --c krank -- first dimension of proj; also, --c n-krank is the second dimension of proj --c --c output: --c a -- the first krank*(n-krank) elements of a constitute --c the krank x (n-krank) matrix proj --c -- implicit none -- integer m,n,krank,j,k,l -- real*8 rnumer,rdenom -- complex*16 a(m,n),sum --c --c --c Overwrite a(1:krank,krank+1:n) with proj. --c -- do k = 1,n-krank -- do j = krank,1,-1 --c -- sum = 0 --c -- do l = j+1,krank -- sum = sum+a(j,l)*a(l,krank+k) -- enddo ! l --c -- a(j,krank+k) = a(j,krank+k)-sum --c --c Make sure that the entry in proj won't be too big; --c set the entry to 0 when roundoff would make it too big --c (in which case a(j,j) is so small that the contribution --c from this entry in proj to the overall matrix approximation --c is supposed to be negligible). --c -- rnumer = a(j,krank+k)*conjg(a(j,krank+k)) -- rdenom = a(j,j)*conjg(a(j,j)) --c -- if(rnumer .lt. 2**30*rdenom) then -- a(j,krank+k) = a(j,krank+k)/a(j,j) -- else -- a(j,krank+k) = 0 -- endif --c -- enddo ! j -- enddo ! k --c --c --c Move proj from a(1:krank,krank+1:n) to the beginning of a. --c -- call idz_moverup(m,n,krank,a) --c --c -- return -- end --c --c --c --c -- subroutine idz_moverup(m,n,krank,a) --c --c moves the krank x (n-krank) matrix in a(1:krank,krank+1:n), --c where a is initially dimensioned m x n, to the beginning of a. --c (This is not the most natural way to code the move, --c but one of my usually well-behaved compilers chokes --c on more natural ways.) --c --c input: --c m -- initial first dimension of a --c n -- initial second dimension of a --c krank -- number of rows to move --c a -- m x n matrix whose krank x (n-krank) block --c a(1:krank,krank+1:n) is to be moved --c --c output: --c a -- array starting with the moved krank x (n-krank) block --c -- implicit none -- integer m,n,krank,j,k -- complex*16 a(m*n) --c --c -- do k = 1,n-krank -- do j = 1,krank -- a(j+krank*(k-1)) = a(j+m*(krank+k-1)) -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_getcols(m,n,matvec,p1,p2,p3,p4,krank,list, -- 1 col,x) --c --c collects together the columns of the matrix a indexed by list --c into the matrix col, where routine matvec applies a --c to an arbitrary vector. --c --c input: --c m -- first dimension of a --c n -- second dimension of a --c matvec -- routine which applies a to an arbitrary vector; --c this routine must have a calling sequence of the form --c --c matvec(m,x,n,y,p1,p2,p3,p4) --c --c where m is the length of x, --c x is the vector to which the matrix is to be applied, --c n is the length of y, --c y is the product of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c krank -- number of columns to be extracted --c list -- indices of the columns to be extracted --c --c output: --c col -- columns of a indexed by list --c --c work: --c x -- must be at least n complex*16 elements long --c -- implicit none -- integer m,n,krank,list(krank),j,k -- complex*16 col(m,krank),x(n),p1,p2,p3,p4 -- external matvec --c --c -- do j = 1,krank --c -- do k = 1,n -- x(k) = 0 -- enddo ! k --c -- x(list(j)) = 1 --c -- call matvec(n,x,m,col(1,j),p1,p2,p3,p4) --c -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idz_reconint(n,list,krank,proj,p) --c --c constructs p in the ID a = b p, --c where the columns of b are a subset of the columns of a, --c and p is the projection coefficient matrix, --c given list, krank, and proj output --c by routines idzp_id or idzr_id. --c --c input: --c n -- part of the second dimension of proj and p --c list -- list of columns retained from the original matrix --c in the ID --c krank -- rank of the ID --c proj -- matrix of projection coefficients in the ID --c --c output: --c p -- projection matrix in the ID --c -- implicit none -- integer n,krank,list(n),j,k -- complex*16 proj(krank,n-krank),p(krank,n) --c --c -- do k = 1,krank -- do j = 1,n --c -- if(j .le. krank) then -- if(j .eq. k) p(k,list(j)) = 1 -- if(j .ne. k) p(k,list(j)) = 0 -- endif --c -- if(j .gt. krank) then -- p(k,list(j)) = proj(k,j-krank) -- endif --c -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_copycols(m,n,a,krank,list,col) --c --c collects together the columns of the matrix a indexed by list --c into the matrix col. --c --c input: --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix whose columns are to be extracted --c krank -- number of columns to be extracted --c list -- indices of the columns to be extracted --c --c output: --c col -- columns of a indexed by list --c -- implicit none -- integer m,n,krank,list(krank),j,k -- complex*16 a(m,n),col(m,krank) --c --c -- do k = 1,krank -- do j = 1,m --c -- col(j,k) = a(j,list(k)) --c -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_id2svd.f b/scipy/linalg/src/id_dist/src/idz_id2svd.f -deleted file mode 100644 -index 55832e5d1..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_id2svd.f -+++ /dev/null -@@ -1,389 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idz_id2svd converts an approximation to a matrix --c in the form of an ID to an approximation in the form of an SVD. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idz_id2svd(m,krank,b,n,list,proj,u,v,s,ier,w) --c --c converts an approximation to a matrix in the form of an ID --c to an approximation in the form of an SVD. --c --c input: --c m -- first dimension of b --c krank -- rank of the ID --c b -- columns of the original matrix in the ID --c list -- list of columns chosen from the original matrix --c in the ID --c n -- length of list and part of the second dimension of proj --c proj -- projection coefficients in the ID --c --c output: --c u -- left singular vectors --c v -- right singular vectors --c s -- singular values --c ier -- 0 when the routine terminates successfully; --c nonzero otherwise --c --c work: --c w -- must be at least (krank+1)*(m+3*n+10)+9*krank**2 --c complex*16 elements long --c --c _N.B._: This routine destroys b. --c -- implicit none -- integer m,krank,n,list(n),iwork,lwork,ip,lp,it,lt,ir,lr, -- 1 ir2,lr2,ir3,lr3,iind,lind,iindt,lindt,lw,ier -- real*8 s(krank) -- complex*16 b(m,krank),proj(krank,n-krank),u(m,krank), -- 1 v(n,krank),w((krank+1)*(m+3*n+10)+9*krank**2) --c --c --c Allocate memory for idz_id2svd0. --c -- lw = 0 --c -- iwork = lw+1 -- lwork = 8*krank**2+10*krank -- lw = lw+lwork --c -- ip = lw+1 -- lp = krank*n -- lw = lw+lp --c -- it = lw+1 -- lt = n*krank -- lw = lw+lt --c -- ir = lw+1 -- lr = krank*n -- lw = lw+lr --c -- ir2 = lw+1 -- lr2 = krank*m -- lw = lw+lr2 --c -- ir3 = lw+1 -- lr3 = krank*krank -- lw = lw+lr3 --c -- iind = lw+1 -- lind = n/4+1 -- lw = lw+1 --c -- iindt = lw+1 -- lindt = m/4+1 -- lw = lw+1 --c --c -- call idz_id2svd0(m,krank,b,n,list,proj,u,v,s,ier, -- 1 w(iwork),w(ip),w(it),w(ir),w(ir2),w(ir3), -- 2 w(iind),w(iindt)) --c --c -- return -- end --c --c --c --c -- subroutine idz_id2svd0(m,krank,b,n,list,proj,u,v,s,ier, -- 1 work,p,t,r,r2,r3,ind,indt) --c --c routine idz_id2svd serves as a memory wrapper --c for the present routine (please see routine idz_id2svd --c for further documentation). --c -- implicit none --c -- character*1 jobz -- integer m,n,krank,list(n),ind(n),indt(m),ifadjoint, -- 1 lwork,ldu,ldvt,ldr,info,j,k,ier -- real*8 s(krank) -- complex*16 b(m,krank),proj(krank,n-krank),p(krank,n), -- 1 r(krank,n),r2(krank,m),t(n,krank),r3(krank,krank), -- 2 u(m,krank),v(n,krank),work(8*krank**2+10*krank) --c --c --c -- ier = 0 --c --c --c --c Construct the projection matrix p from the ID. --c -- call idz_reconint(n,list,krank,proj,p) --c --c --c --c Compute a pivoted QR decomposition of b. --c -- call idzr_qrpiv(m,krank,b,krank,ind,r) --c --c --c Extract r from the QR decomposition. --c -- call idz_rinqr(m,krank,b,krank,r) --c --c --c Rearrange r according to ind. --c -- call idz_rearr(krank,ind,krank,krank,r) --c --c --c --c Take the adjoint of p to obtain t. --c -- call idz_matadj(krank,n,p,t) --c --c --c Compute a pivoted QR decomposition of t. --c -- call idzr_qrpiv(n,krank,t,krank,indt,r2) --c --c --c Extract r2 from the QR decomposition. --c -- call idz_rinqr(n,krank,t,krank,r2) --c --c --c Rearrange r2 according to indt. --c -- call idz_rearr(krank,indt,krank,krank,r2) --c --c --c --c Multiply r and r2^* to obtain r3. --c -- call idz_matmulta(krank,krank,r,krank,r2,r3) --c --c --c --c Use LAPACK to SVD r3. --c -- jobz = 'S' -- ldr = krank -- lwork = 8*krank**2+10*krank -- 1 - (krank**2+2*krank+3*krank**2+4*krank) -- ldu = krank -- ldvt = krank --c -- call zgesdd(jobz,krank,krank,r3,ldr,s,work,ldu,r,ldvt, -- 1 work(krank**2+2*krank+3*krank**2+4*krank+1),lwork, -- 2 work(krank**2+2*krank+1),work(krank**2+1),info) --c -- if(info .ne. 0) then -- ier = info -- return -- endif --c --c --c --c Multiply the u from r3 from the left by the q from b --c to obtain the u for a. --c -- do k = 1,krank --c -- do j = 1,krank -- u(j,k) = work(j+krank*(k-1)) -- enddo ! j --c -- do j = krank+1,m -- u(j,k) = 0 -- enddo ! j --c -- enddo ! k --c -- ifadjoint = 0 -- call idz_qmatmat(ifadjoint,m,krank,b,krank,krank,u,r2) --c --c --c --c Take the adjoint of r to obtain r2. --c -- call idz_matadj(krank,krank,r,r2) --c --c --c Multiply the v from r3 from the left by the q from p^* --c to obtain the v for a. --c -- do k = 1,krank --c -- do j = 1,krank -- v(j,k) = r2(j,k) -- enddo ! j --c -- do j = krank+1,n -- v(j,k) = 0 -- enddo ! j --c -- enddo ! k --c -- ifadjoint = 0 -- call idz_qmatmat(ifadjoint,n,krank,t,krank,krank,v,r2) --c --c -- return -- end --c --c --c --c -- subroutine idz_matadj(m,n,a,aa) --c --c Takes the adjoint of a to obtain aa. --c --c input: --c m -- first dimension of a, and second dimension of aa --c n -- second dimension of a, and first dimension of aa --c a -- matrix whose adjoint is to be taken --c --c output: --c aa -- adjoint of a --c -- implicit none -- integer m,n,j,k -- complex*16 a(m,n),aa(n,m) --c --c -- do k = 1,n -- do j = 1,m -- aa(k,j) = conjg(a(j,k)) -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_matmulta(l,m,a,n,b,c) --c --c multiplies a and b^* to obtain c. --c --c input: --c l -- first dimension of a and c --c m -- second dimension of a and b --c a -- leftmost matrix in the product c = a b^* --c n -- first dimension of b and second dimension of c --c b -- rightmost matrix in the product c = a b^* --c --c output: --c c -- product of a and b^* --c -- implicit none -- integer l,m,n,i,j,k -- complex*16 a(l,m),b(n,m),c(l,n),sum --c --c -- do i = 1,l -- do k = 1,n --c -- sum = 0 --c -- do j = 1,m -- sum = sum+a(i,j)*conjg(b(k,j)) -- enddo ! j --c -- c(i,k) = sum --c -- enddo ! k -- enddo ! i --c --c -- return -- end --c --c --c --c -- subroutine idz_rearr(krank,ind,m,n,a) --c --c rearranges a according to ind obtained --c from routines idzr_qrpiv or idzp_qrpiv, --c assuming that a = q r, where q and r are from idzr_qrpiv --c or idzp_qrpiv. --c --c input: --c krank -- rank obtained from routine idzp_qrpiv, --c or provided to routine idzr_qrpiv --c ind -- indexing array obtained from routine idzr_qrpiv --c or idzp_qrpiv --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix to be rearranged --c --c output: --c a -- rearranged matrix --c -- implicit none -- integer k,krank,m,n,j,ind(krank) -- complex*16 cswap,a(m,n) --c --c -- do k = krank,1,-1 -- do j = 1,m --c -- cswap = a(j,k) -- a(j,k) = a(j,ind(k)) -- a(j,ind(k)) = cswap --c -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_rinqr(m,n,a,krank,r) --c --c extracts R in the QR decomposition specified by the output a --c of the routine idzr_qrpiv or idzp_qrpiv. --c --c input: --c m -- first dimension of a --c n -- second dimension of a and r --c a -- output of routine idzr_qrpiv or idzp_qrpiv --c krank -- rank output by routine idzp_qrpiv (or specified --c to routine idzr_qrpiv) --c --c output: --c r -- triangular factor in the QR decomposition specified --c by the output a of the routine idzr_qrpiv or idzp_qrpiv --c -- implicit none -- integer m,n,j,k,krank -- complex*16 a(m,n),r(krank,n) --c --c --c Copy a into r and zero out the appropriate --c Householder vectors that are stored in one triangle of a. --c -- do k = 1,n -- do j = 1,krank -- r(j,k) = a(j,k) -- enddo ! j -- enddo ! k --c -- do k = 1,n -- if(k .lt. krank) then -- do j = k+1,krank -- r(j,k) = 0 -- enddo ! j -- endif -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_qrpiv.f b/scipy/linalg/src/id_dist/src/idz_qrpiv.f -deleted file mode 100644 -index 3e7bcaf99..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_qrpiv.f -+++ /dev/null -@@ -1,898 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzp_qrpiv computes the pivoted QR decomposition --c of a matrix via Householder transformations, --c stopping at a specified precision of the decomposition. --c --c routine idzr_qrpiv computes the pivoted QR decomposition --c of a matrix via Householder transformations, --c stopping at a specified rank of the decomposition. --c --c routine idz_qmatvec applies to a single vector --c the Q matrix (or its adjoint) in the QR decomposition --c of a matrix, as described by the output of idzp_qrpiv or --c idzr_qrpiv. If you're concerned about efficiency and want --c to apply Q (or its adjoint) to multiple vectors, --c use idz_qmatmat instead. --c --c routine idz_qmatmat applies --c to multiple vectors collected together --c as a matrix the Q matrix (or its adjoint) --c in the QR decomposition of a matrix, as described --c by the output of idzp_qrpiv. If you don't want to provide --c a work array and want to apply Q (or its adjoint) --c to a single vector, use idz_qmatvec instead. --c --c routine idz_qinqr reconstructs the Q matrix --c in a QR decomposition from the data generated by idzp_qrpiv --c or idzr_qrpiv. --c --c routine idz_permmult multiplies together a bunch --c of permutations. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idz_permmult(m,ind,n,indprod) --c --c multiplies together the series of permutations in ind. --c --c input: --c m -- length of ind --c ind(k) -- number of the slot with which to swap --c the k^th slot --c n -- length of indprod and indprodinv --c --c output: --c indprod -- product of the permutations in ind, --c with the permutation swapping 1 and ind(1) --c taken leftmost in the product, --c that swapping 2 and ind(2) taken next leftmost, --c ..., that swapping krank and ind(krank) --c taken rightmost; indprod(k) is the number --c of the slot with which to swap the k^th slot --c in the product permutation --c -- implicit none -- integer m,n,ind(m),indprod(n),k,iswap --c --c -- do k = 1,n -- indprod(k) = k -- enddo ! k --c -- do k = m,1,-1 --c --c Swap indprod(k) and indprod(ind(k)). --c -- iswap = indprod(k) -- indprod(k) = indprod(ind(k)) -- indprod(ind(k)) = iswap --c -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_qinqr(m,n,a,krank,q) --c --c constructs the matrix q from idzp_qrpiv or idzr_qrpiv --c (see the routine idzp_qrpiv or idzr_qrpiv --c for more information). --c --c input: --c m -- first dimension of a; also, right now, q is m x m --c n -- second dimension of a --c a -- matrix output by idzp_qrpiv or idzr_qrpiv --c (and denoted the same there) --c krank -- numerical rank output by idzp_qrpiv or idzr_qrpiv --c (and denoted the same there) --c --c output: --c q -- unitary matrix implicitly specified by the data in a --c from idzp_qrpiv or idzr_qrpiv --c --c Note: --c Right now, this routine simply multiplies --c one after another the krank Householder matrices --c in the full QR decomposition of a, --c in order to obtain the complete m x m Q factor in the QR. --c This routine should instead use the following --c (more elaborate but more efficient) scheme --c to construct a q dimensioned q(krank,m); this scheme --c was introduced by Robert Schreiber and Charles Van Loan --c in "A Storage-Efficient _WY_ Representation --c for Products of Householder Transformations," --c _SIAM Journal on Scientific and Statistical Computing_, --c Vol. 10, No. 1, pp. 53-57, January, 1989: --c --c Theorem 1. Suppose that Q = _1_ + YTY^* is --c an m x m unitary matrix, --c where Y is an m x k matrix --c and T is a k x k upper triangular matrix. --c Suppose also that P = _1_ - 2 v v^* is --c a Householder matrix and Q_+ = QP, --c where v is an m x 1 real vector, --c normalized so that v^* v = 1. --c Then, Q_+ = _1_ + Y_+ T_+ Y_+^*, --c where Y_+ = (Y v) is the m x (k+1) matrix --c formed by adjoining v to the right of Y, --c ( T z ) --c and T_+ = ( ) is --c ( 0 -2 ) --c the (k+1) x (k+1) upper triangular matrix --c formed by adjoining z to the right of T --c and the vector (0 ... 0 -2) with k zeroes below (T z), --c where z = -2 T Y^* v. --c --c Now, suppose that A is a (rank-deficient) matrix --c whose complete QR decomposition has --c the blockwise partioned form --c ( Q_11 Q_12 ) ( R_11 R_12 ) ( Q_11 ) --c A = ( ) ( ) = ( ) (R_11 R_12). --c ( Q_21 Q_22 ) ( 0 0 ) ( Q_21 ) --c Then, the only blocks of the orthogonal factor --c in the above QR decomposition of A that matter are --c ( Q_11 ) --c Q_11 and Q_21, _i.e._, only the block of columns ( ) --c ( Q_21 ) --c interests us. --c Suppose in addition that Q_11 is a k x k matrix, --c Q_21 is an (m-k) x k matrix, and that --c ( Q_11 Q_12 ) --c ( ) = _1_ + YTY^*, as in Theorem 1 above. --c ( Q_21 Q_22 ) --c Then, Q_11 = _1_ + Y_1 T Y_1^* --c and Q_21 = Y_2 T Y_1^*, --c where Y_1 is the k x k matrix and Y_2 is the (m-k) x k matrix --c ( Y_1 ) --c so that Y = ( ). --c ( Y_2 ) --c --c So, you can calculate T and Y via the above recursions, --c and then use these to compute the desired Q_11 and Q_21. --c --c -- implicit none -- integer m,n,krank,j,k,mm,ifrescal -- real*8 scal -- complex*16 a(m,n),q(m,m) --c --c --c Zero all of the entries of q. --c -- do k = 1,m -- do j = 1,m -- q(j,k) = 0 -- enddo ! j -- enddo ! k --c --c --c Place 1's along the diagonal of q. --c -- do k = 1,m -- q(k,k) = 1 -- enddo ! k --c --c --c Apply the krank Householder transformations stored in a. --c -- do k = krank,1,-1 -- do j = k,m -- mm = m-k+1 -- ifrescal = 1 -- if(k .lt. m) call idz_houseapp(mm,a(k+1,k),q(k,j), -- 1 ifrescal,scal,q(k,j)) -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_qmatvec(ifadjoint,m,n,a,krank,v) --c --c applies to a single vector the Q matrix (or its adjoint) --c which the routine idzp_qrpiv or idzr_qrpiv has stored --c in a triangle of the matrix it produces (stored, incidentally, --c as data for applying a bunch of Householder reflections). --c Use the routine idz_qmatmat to apply the Q matrix --c (or its adjoint) --c to a bunch of vectors collected together as a matrix, --c if you're concerned about efficiency. --c --c input: --c ifadjoint -- set to 0 for applying Q; --c set to 1 for applying the adjoint of Q --c m -- first dimension of a and length of v --c n -- second dimension of a --c a -- data describing the qr decomposition of a matrix, --c as produced by idzp_qrpiv or idzr_qrpiv --c krank -- numerical rank --c v -- vector to which Q (or its adjoint) is to be applied --c --c output: --c v -- vector to which Q (or its adjoint) has been applied --c -- implicit none -- save -- integer m,n,krank,k,ifrescal,mm,ifadjoint -- real*8 scal -- complex*16 a(m,n),v(m) --c --c -- ifrescal = 1 --c --c -- if(ifadjoint .eq. 0) then --c -- do k = krank,1,-1 -- mm = m-k+1 -- if(k .lt. m) call idz_houseapp(mm,a(k+1,k),v(k), -- 1 ifrescal,scal,v(k)) -- enddo ! k --c -- endif --c --c -- if(ifadjoint .eq. 1) then --c -- do k = 1,krank -- mm = m-k+1 -- if(k .lt. m) call idz_houseapp(mm,a(k+1,k),v(k), -- 1 ifrescal,scal,v(k)) -- enddo ! k --c -- endif --c --c -- return -- end --c --c --c --c -- subroutine idz_qmatmat(ifadjoint,m,n,a,krank,l,b,work) --c --c applies to a bunch of vectors collected together as a matrix --c the Q matrix (or its adjoint) which the routine idzp_qrpiv --c or idzr_qrpiv has stored in a triangle of the matrix --c it produces (stored, incidentally, as data --c for applying a bunch of Householder reflections). --c Use the routine idz_qmatvec to apply the Q matrix --c (or its adjoint) --c to a single vector, if you'd rather not provide a work array. --c --c input: --c ifadjoint -- set to 0 for applying Q; --c set to 1 for applying the adjoint of Q --c m -- first dimension of both a and b --c n -- second dimension of a --c a -- data describing the qr decomposition of a matrix, --c as produced by idzp_qrpiv or idzr_qrpiv --c krank -- numerical rank --c l -- second dimension of b --c b -- matrix to which Q (or its adjoint) is to be applied --c --c output: --c b -- matrix to which Q (or its adjoint) has been applied --c --c work: --c work -- must be at least krank real*8 elements long --c -- implicit none -- save -- integer l,m,n,krank,j,k,ifrescal,mm,ifadjoint -- real*8 work(krank) -- complex*16 a(m,n),b(m,l) --c --c -- if(ifadjoint .eq. 0) then --c --c --c Handle the first iteration, j = 1, --c calculating all scals (ifrescal = 1). --c -- ifrescal = 1 --c -- j = 1 --c -- do k = krank,1,-1 -- if(k .lt. m) then -- mm = m-k+1 -- call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c --c -- if(l .gt. 1) then --c --c Handle the other iterations, j > 1, --c using the scals just computed (ifrescal = 0). --c -- ifrescal = 0 --c -- do j = 2,l --c -- do k = krank,1,-1 -- if(k .lt. m) then -- mm = m-k+1 -- call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c -- enddo ! j --c -- endif ! j .gt. 1 --c --c -- endif ! ifadjoint .eq. 0 --c --c -- if(ifadjoint .eq. 1) then --c --c --c Handle the first iteration, j = 1, --c calculating all scals (ifrescal = 1). --c -- ifrescal = 1 --c -- j = 1 --c -- do k = 1,krank -- if(k .lt. m) then -- mm = m-k+1 -- call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c --c -- if(l .gt. 1) then --c --c Handle the other iterations, j > 1, --c using the scals just computed (ifrescal = 0). --c -- ifrescal = 0 --c -- do j = 2,l --c -- do k = 1,krank -- if(k .lt. m) then -- mm = m-k+1 -- call idz_houseapp(mm,a(k+1,k),b(k,j),ifrescal, -- 1 work(k),b(k,j)) -- endif -- enddo ! k --c -- enddo ! j --c -- endif ! j .gt. 1 --c --c -- endif ! ifadjoint .eq. 1 --c --c -- return -- end --c --c --c --c -- subroutine idzp_qrpiv(eps,m,n,a,krank,ind,ss) --c --c computes the pivoted QR decomposition --c of the matrix input into a, using Householder transformations, --c _i.e._, transforms the matrix a from its input value in --c to the matrix out with entry --c --c m --c out(j,indprod(k)) = Sigma q(l,j) * in(l,k), --c l=1 --c --c for all j = 1, ..., krank, and k = 1, ..., n, --c --c where in = the a from before the routine runs, --c out = the a from after the routine runs, --c out(j,k) = 0 when j > k (so that out is triangular), --c q(1:m,1), ..., q(1:m,krank) are orthonormal, --c indprod is the product of the permutations given by ind, --c (as computable via the routine permmult, --c with the permutation swapping 1 and ind(1) taken leftmost --c in the product, that swapping 2 and ind(2) taken next leftmost, --c ..., that swapping krank and ind(krank) taken rightmost), --c and with the matrix out satisfying --c --c krank --c in(j,k) = Sigma q(j,l) * out(l,indprod(k)) + epsilon(j,k), --c l=1 --c --c for all j = 1, ..., m, and k = 1, ..., n, --c --c for some matrix epsilon such that --c the root-sum-square of the entries of epsilon --c <= the root-sum-square of the entries of in * eps. --c Well, technically, this routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c input: --c eps -- relative precision of the resulting QR decomposition --c m -- first dimension of a and q --c n -- second dimension of a --c a -- matrix whose QR decomposition gets computed --c --c output: --c a -- triangular (R) factor in the QR decompositon --c of the matrix input into the same storage locations, --c with the Householder vectors stored in the part of a --c that would otherwise consist entirely of zeroes, that is, --c in a(j,k) with m >= j > k >= 1 --c krank -- numerical rank --c ind(k) -- index of the k^th pivot vector; --c the following code segment will correctly rearrange --c the product b of q and the upper triangle of out --c so that b matches the input matrix in --c to relative precision eps: --c --c copy the non-rearranged product of q and out into b --c set k to krank --c [start of loop] --c swap b(1:m,k) and b(1:m,ind(k)) --c decrement k by 1 --c if k > 0, then go to [start of loop] --c --c work: --c ss -- must be at least n real*8 words long --c --c _N.B._: This routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- integer n,m,ind(n),krank,k,j,kpiv,mm,nupdate,ifrescal -- real*8 ss(n),eps,ssmax,scal,ssmaxin,rswap,feps -- complex*16 a(m,n),cswap --c --c -- feps = .1d-16 --c --c --c Compute the sum of squares of the entries in each column of a, --c the maximum of all such sums, and find the first pivot --c (column with the greatest such sum). --c -- ssmax = 0 -- kpiv = 1 --c -- do k = 1,n --c -- ss(k) = 0 -- do j = 1,m -- ss(k) = ss(k)+a(j,k)*conjg(a(j,k)) -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- ssmaxin = ssmax --c -- nupdate = 0 --c --c --c While ssmax > eps**2*ssmaxin, krank < m, and krank < n, --c do the following block of code, --c which ends at the statement labeled 2000. --c -- krank = 0 -- 1000 continue --c -- if(ssmax .le. eps**2*ssmaxin -- 1 .or. krank .ge. m .or. krank .ge. n) goto 2000 -- krank = krank+1 --c --c -- mm = m-krank+1 --c --c --c Perform the pivoting. --c -- ind(krank) = kpiv --c --c Swap a(1:m,krank) and a(1:m,kpiv). --c -- do j = 1,m -- cswap = a(j,krank) -- a(j,krank) = a(j,kpiv) -- a(j,kpiv) = cswap -- enddo ! j --c --c Swap ss(krank) and ss(kpiv). --c -- rswap = ss(krank) -- ss(krank) = ss(kpiv) -- ss(kpiv) = rswap --c --c -- if(krank .lt. m) then --c --c --c Compute the data for the Householder transformation --c which will zero a(krank+1,krank), ..., a(m,krank) --c when applied to a, replacing a(krank,krank) --c with the first entry of the result of the application --c of the Householder matrix to a(krank:m,krank), --c and storing entries 2 to mm of the Householder vector --c in a(krank+1,krank), ..., a(m,krank) --c (which otherwise would get zeroed upon application --c of the Householder transformation). --c -- call idz_house(mm,a(krank,krank),a(krank,krank), -- 1 a(krank+1,krank),scal) -- ifrescal = 0 --c --c --c Apply the Householder transformation --c to the lower right submatrix of a --c with upper leftmost entry at position (krank,krank+1). --c -- if(krank .lt. n) then -- do k = krank+1,n -- call idz_houseapp(mm,a(krank+1,krank),a(krank,k), -- 1 ifrescal,scal,a(krank,k)) -- enddo ! k -- endif --c --c --c Update the sums-of-squares array ss. --c -- do k = krank,n -- ss(k) = ss(k)-a(krank,k)*conjg(a(krank,k)) -- enddo ! k --c --c --c Find the pivot (column with the greatest sum of squares --c of its entries). --c -- ssmax = 0 -- kpiv = krank+1 --c -- if(krank .lt. n) then --c -- do k = krank+1,n --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! krank .lt. n --c --c --c Recompute the sums-of-squares and the pivot --c when ssmax first falls below --c sqrt((1000*feps)^2) * ssmaxin --c and when ssmax first falls below --c ((1000*feps)^2) * ssmaxin. --c -- if( -- 1 (ssmax .lt. sqrt((1000*feps)**2) * ssmaxin -- 2 .and. nupdate .eq. 0) .or. -- 3 (ssmax .lt. ((1000*feps)**2) * ssmaxin -- 4 .and. nupdate .eq. 1) -- 5 ) then --c -- nupdate = nupdate+1 --c -- ssmax = 0 -- kpiv = krank+1 --c -- if(krank .lt. n) then --c -- do k = krank+1,n --c -- ss(k) = 0 -- do j = krank+1,m -- ss(k) = ss(k)+a(j,k)*conjg(a(j,k)) -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! krank .lt. n --c -- endif --c --c -- endif ! krank .lt. m --c --c -- goto 1000 -- 2000 continue --c --c -- return -- end --c --c --c --c -- subroutine idzr_qrpiv(m,n,a,krank,ind,ss) --c --c computes the pivoted QR decomposition --c of the matrix input into a, using Householder transformations, --c _i.e._, transforms the matrix a from its input value in --c to the matrix out with entry --c --c m --c out(j,indprod(k)) = Sigma q(l,j) * in(l,k), --c l=1 --c --c for all j = 1, ..., krank, and k = 1, ..., n, --c --c where in = the a from before the routine runs, --c out = the a from after the routine runs, --c out(j,k) = 0 when j > k (so that out is triangular), --c q(1:m,1), ..., q(1:m,krank) are orthonormal, --c indprod is the product of the permutations given by ind, --c (as computable via the routine permmult, --c with the permutation swapping 1 and ind(1) taken leftmost --c in the product, that swapping 2 and ind(2) taken next leftmost, --c ..., that swapping krank and ind(krank) taken rightmost), --c and with the matrix out satisfying --c --c min(m,n,krank) --c in(j,k) = Sigma q(j,l) * out(l,indprod(k)) --c l=1 --c --c + epsilon(j,k), --c --c for all j = 1, ..., m, and k = 1, ..., n, --c --c for some matrix epsilon whose norm is (hopefully) minimized --c by the pivoting procedure. --c Well, technically, this routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c input: --c m -- first dimension of a and q --c n -- second dimension of a --c a -- matrix whose QR decomposition gets computed --c krank -- desired rank of the output matrix --c (please note that if krank > m or krank > n, --c then the rank of the output matrix will be --c less than krank) --c --c output: --c a -- triangular (R) factor in the QR decompositon --c of the matrix input into the same storage locations, --c with the Householder vectors stored in the part of a --c that would otherwise consist entirely of zeroes, that is, --c in a(j,k) with m >= j > k >= 1 --c ind(k) -- index of the k^th pivot vector; --c the following code segment will correctly rearrange --c the product b of q and the upper triangle of out --c so that b matches the input matrix in --c to relative precision eps: --c --c copy the non-rearranged product of q and out into b --c set k to krank --c [start of loop] --c swap b(1:m,k) and b(1:m,ind(k)) --c decrement k by 1 --c if k > 0, then go to [start of loop] --c --c work: --c ss -- must be at least n real*8 words long --c --c _N.B._: This routine outputs the Householder vectors --c (or, rather, their second through last entries) --c in the part of a that is supposed to get zeroed, that is, --c in a(j,k) with m >= j > k >= 1. --c --c reference: --c Golub and Van Loan, "Matrix Computations," 3rd edition, --c Johns Hopkins University Press, 1996, Chapter 5. --c -- implicit none -- integer n,m,ind(n),krank,k,j,kpiv,mm,nupdate,ifrescal, -- 1 loops,loop -- real*8 ss(n),ssmax,scal,ssmaxin,rswap,feps -- complex*16 a(m,n),cswap --c --c -- feps = .1d-16 --c --c --c Compute the sum of squares of the entries in each column of a, --c the maximum of all such sums, and find the first pivot --c (column with the greatest such sum). --c -- ssmax = 0 -- kpiv = 1 --c -- do k = 1,n --c -- ss(k) = 0 -- do j = 1,m -- ss(k) = ss(k)+a(j,k)*conjg(a(j,k)) -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- ssmaxin = ssmax --c -- nupdate = 0 --c --c --c Set loops = min(krank,m,n). --c -- loops = krank -- if(m .lt. loops) loops = m -- if(n .lt. loops) loops = n --c -- do loop = 1,loops --c --c -- mm = m-loop+1 --c --c --c Perform the pivoting. --c -- ind(loop) = kpiv --c --c Swap a(1:m,loop) and a(1:m,kpiv). --c -- do j = 1,m -- cswap = a(j,loop) -- a(j,loop) = a(j,kpiv) -- a(j,kpiv) = cswap -- enddo ! j --c --c Swap ss(loop) and ss(kpiv). --c -- rswap = ss(loop) -- ss(loop) = ss(kpiv) -- ss(kpiv) = rswap --c --c -- if(loop .lt. m) then --c --c --c Compute the data for the Householder transformation --c which will zero a(loop+1,loop), ..., a(m,loop) --c when applied to a, replacing a(loop,loop) --c with the first entry of the result of the application --c of the Householder matrix to a(loop:m,loop), --c and storing entries 2 to mm of the Householder vector --c in a(loop+1,loop), ..., a(m,loop) --c (which otherwise would get zeroed upon application --c of the Householder transformation). --c -- call idz_house(mm,a(loop,loop),a(loop,loop), -- 1 a(loop+1,loop),scal) -- ifrescal = 0 --c --c --c Apply the Householder transformation --c to the lower right submatrix of a --c with upper leftmost entry at position (loop,loop+1). --c -- if(loop .lt. n) then -- do k = loop+1,n -- call idz_houseapp(mm,a(loop+1,loop),a(loop,k), -- 1 ifrescal,scal,a(loop,k)) -- enddo ! k -- endif --c --c --c Update the sums-of-squares array ss. --c -- do k = loop,n -- ss(k) = ss(k)-a(loop,k)*conjg(a(loop,k)) -- enddo ! k --c --c --c Find the pivot (column with the greatest sum of squares --c of its entries). --c -- ssmax = 0 -- kpiv = loop+1 --c -- if(loop .lt. n) then --c -- do k = loop+1,n --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! loop .lt. n --c --c --c Recompute the sums-of-squares and the pivot --c when ssmax first falls below --c sqrt((1000*feps)^2) * ssmaxin --c and when ssmax first falls below --c ((1000*feps)^2) * ssmaxin. --c -- if( -- 1 (ssmax .lt. sqrt((1000*feps)**2) * ssmaxin -- 2 .and. nupdate .eq. 0) .or. -- 3 (ssmax .lt. ((1000*feps)**2) * ssmaxin -- 4 .and. nupdate .eq. 1) -- 5 ) then --c -- nupdate = nupdate+1 --c -- ssmax = 0 -- kpiv = loop+1 --c -- if(loop .lt. n) then --c -- do k = loop+1,n --c -- ss(k) = 0 -- do j = loop+1,m -- ss(k) = ss(k)+a(j,k)*conjg(a(j,k)) -- enddo ! j --c -- if(ss(k) .gt. ssmax) then -- ssmax = ss(k) -- kpiv = k -- endif --c -- enddo ! k --c -- endif ! loop .lt. n --c -- endif --c --c -- endif ! loop .lt. m --c --c -- enddo ! loop --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_sfft.f b/scipy/linalg/src/id_dist/src/idz_sfft.f -deleted file mode 100644 -index c8dd9ab18..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_sfft.f -+++ /dev/null -@@ -1,210 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idz_sffti initializes routine idz_sfft. --c --c routine idz_sfft rapidly computes a subset of the entries --c of the DFT of a vector, composed with permutation matrices --c both on input and on output. --c --c routine idz_ldiv finds the greatest integer less than or equal --c to a specified integer, that is divisible by another (larger) --c specified integer. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idz_ldiv(l,n,m) --c --c finds the greatest integer less than or equal to l --c that divides n. --c --c input: --c l -- integer at least as great as m --c n -- integer divisible by m --c --c output: --c m -- greatest integer less than or equal to l that divides n --c -- implicit none -- integer n,l,m --c --c -- m = l --c -- 1000 continue -- if(m*(n/m) .eq. n) goto 2000 --c -- m = m-1 -- goto 1000 --c -- 2000 continue --c --c -- return -- end --c --c --c --c -- subroutine idz_sffti(l,ind,n,wsave) --c --c initializes wsave for use with routine idz_sfft. --c --c input: --c l -- number of entries in the output of idz_sfft to compute --c ind -- indices of the entries in the output of idz_sfft --c to compute --c n -- length of the vector to be transformed --c --c output: --c wsave -- array needed by routine idz_sfft for processing --c -- implicit none -- integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k -- real*8 r1,twopi,fact -- complex*16 wsave(2*l+15+3*n),ci,twopii --c -- ci = (0,1) -- r1 = 1 -- twopi = 2*4*atan(r1) -- twopii = twopi*ci --c --c --c Determine the block lengths for the FFTs. --c -- call idz_ldiv(l,n,nblock) -- m = n/nblock --c --c --c Initialize wsave for use with routine zfftf. --c -- call zffti(nblock,wsave) --c --c --c Calculate the coefficients in the linear combinations --c needed for the direct portion of the calculation. --c -- fact = 1/sqrt(r1*n) --c -- ii = 2*l+15 --c -- do j = 1,l --c -- i = ind(j) --c -- idivm = (i-1)/m -- imodm = (i-1)-m*idivm --c -- do k = 1,m -- wsave(ii+m*(j-1)+k) = exp(-twopii*imodm*(k-1)/(r1*m)) -- 1 * exp(-twopii*(k-1)*idivm/(r1*n)) * fact -- enddo ! k --c -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idz_sfft(l,ind,n,wsave,v) --c --c computes a subset of the entries of the DFT of v, --c composed with permutation matrices both on input and on output, --c via a two-stage procedure (routine zfftf2 is supposed --c to calculate the full vector from which idz_sfft returns --c a subset of the entries, when zfftf2 has the same parameter --c nblock as in the present routine). --c --c input: --c l -- number of entries in the output to compute --c ind -- indices of the entries of the output to compute --c n -- length of v --c v -- vector to be transformed --c wsave -- processing array initialized by routine idz_sffti --c --c output: --c v -- entries indexed by ind are given their appropriate --c transformed values --c --c _N.B._: The user has to boost the memory allocations --c for wsave (and change iii accordingly) if s/he wishes --c to use strange sizes of n; it's best to stick to powers --c of 2. --c --c references: --c Sorensen and Burrus, "Efficient computation of the DFT with --c only a subset of input or output points," --c IEEE Transactions on Signal Processing, 41 (3): 1184-1200, --c 1993. --c Woolfe, Liberty, Rokhlin, Tygert, "A fast randomized algorithm --c for the approximation of matrices," Applied and --c Computational Harmonic Analysis, 25 (3): 335-366, 2008; --c Section 3.3. --c -- implicit none -- integer n,m,l,k,j,ind(l),i,idivm,nblock,ii,iii -- real*8 r1,twopi -- complex*16 v(n),wsave(2*l+15+3*n),ci,sum --c -- ci = (0,1) -- r1 = 1 -- twopi = 2*4*atan(r1) --c --c --c Determine the block lengths for the FFTs. --c -- call idz_ldiv(l,n,nblock) --c --c -- m = n/nblock --c --c --c FFT each block of length nblock of v. --c -- do k = 1,m -- call zfftf(nblock,v(nblock*(k-1)+1),wsave) -- enddo ! k --c --c --c Transpose v to obtain wsave(2*l+15+2*n+1 : 2*l+15+3*n). --c -- iii = 2*l+15+2*n --c -- do k = 1,m -- do j = 1,nblock -- wsave(iii+m*(j-1)+k) = v(nblock*(k-1)+j) -- enddo ! j -- enddo ! k --c --c --c Directly calculate the desired entries of v. --c -- ii = 2*l+15 -- iii = 2*l+15+2*n --c -- do j = 1,l --c -- i = ind(j) --c -- idivm = (i-1)/m --c -- sum = 0 --c -- do k = 1,m -- sum = sum + wsave(ii+m*(j-1)+k) * wsave(iii+m*idivm+k) -- enddo ! k --c -- v(i) = sum --c -- enddo ! j --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_snorm.f b/scipy/linalg/src/id_dist/src/idz_snorm.f -deleted file mode 100644 -index 9fe713d47..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_snorm.f -+++ /dev/null -@@ -1,407 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idz_snorm estimates the spectral norm --c of a matrix specified by routines for applying the matrix --c and its adjoint to arbitrary vectors. This routine uses --c the power method with a random starting vector. --c --c routine idz_diffsnorm estimates the spectral norm --c of the difference between two matrices specified by routines --c for applying the matrices and their adjoints --c to arbitrary vectors. This routine uses --c the power method with a random starting vector. --c --c routine idz_enorm calculates the Euclidean norm of a vector. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idz_snorm(m,n,matveca,p1a,p2a,p3a,p4a, -- 1 matvec,p1,p2,p3,p4,its,snorm,v,u) --c --c estimates the spectral norm of a matrix a specified --c by a routine matvec for applying a to an arbitrary vector, --c and by a routine matveca for applying a^* --c to an arbitrary vector. This routine uses the power method --c with a random starting vector. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c matveca -- routine which applies the adjoint of a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matveca(m,x,n,y,p1a,p2a,p3a,p4a), --c --c where m is the length of x, --c x is the vector to which the adjoint of a --c is to be applied, --c n is the length of y, --c y is the product of the adjoint of a and x, --c and p1a, p2a, p3a, and p4a are user-specified --c parameters --c p1a -- parameter to be passed to routine matveca --c p2a -- parameter to be passed to routine matveca --c p3a -- parameter to be passed to routine matveca --c p4a -- parameter to be passed to routine matveca --c matvec -- routine which applies the matrix a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which a is to be applied, --c m is the length of y, --c y is the product of a and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c its -- number of iterations of the power method to conduct --c --c output: --c snorm -- estimate of the spectral norm of a --c v -- estimate of a normalized right singular vector --c corresponding to the greatest singular value of a --c --c work: --c u -- must be at least m complex*16 elements long --c --c reference: --c Kuczynski and Wozniakowski, "Estimating the largest eigenvalue --c by the power and Lanczos algorithms with a random start," --c SIAM Journal on Matrix Analysis and Applications, --c 13 (4): 1992, 1094-1122. --c -- implicit none -- integer m,n,its,it,n2,k -- real*8 snorm,enorm -- complex*16 p1a,p2a,p3a,p4a,p1,p2,p3,p4,u(m),v(n) -- external matveca,matvec --c --c --c Fill the real and imaginary parts of each entry --c of the initial vector v with i.i.d. random variables --c drawn uniformly from [-1,1]. --c -- n2 = 2*n -- call id_srand(n2,v) --c -- do k = 1,n -- v(k) = 2*v(k)-1 -- enddo ! k --c --c --c Normalize v. --c -- call idz_enorm(n,v,enorm) --c -- do k = 1,n -- v(k) = v(k)/enorm -- enddo ! k --c --c -- do it = 1,its --c --c Apply a to v, obtaining u. --c -- call matvec(n,v,m,u,p1,p2,p3,p4) --c --c Apply a^* to u, obtaining v. --c -- call matveca(m,u,n,v,p1a,p2a,p3a,p4a) --c --c Normalize v. --c -- call idz_enorm(n,v,snorm) --c -- if(snorm .ne. 0) then --c -- do k = 1,n -- v(k) = v(k)/snorm -- enddo ! k --c -- endif --c -- snorm = sqrt(snorm) --c -- enddo ! it --c --c -- return -- end --c --c --c --c -- subroutine idz_enorm(n,v,enorm) --c --c computes the Euclidean norm of v, the square root --c of the sum of the squares of the absolute values --c of the entries of v. --c --c input: --c n -- length of v --c v -- vector whose Euclidean norm is to be calculated --c --c output: --c enorm -- Euclidean norm of v --c -- implicit none -- integer n,k -- real*8 enorm -- complex*16 v(n) --c --c -- enorm = 0 --c -- do k = 1,n -- enorm = enorm+v(k)*conjg(v(k)) -- enddo ! k --c -- enorm = sqrt(enorm) --c --c -- return -- end --c --c --c --c -- subroutine idz_diffsnorm(m,n,matveca,p1a,p2a,p3a,p4a, -- 1 matveca2,p1a2,p2a2,p3a2,p4a2, -- 2 matvec,p1,p2,p3,p4, -- 3 matvec2,p12,p22,p32,p42,its,snorm,w) --c --c estimates the spectral norm of the difference between matrices --c a and a2, where a is specified by routines matvec and matveca --c for applying a and a^* to arbitrary vectors, --c and a2 is specified by routines matvec2 and matveca2 --c for applying a2 and (a2)^* to arbitrary vectors. --c This routine uses the power method --c with a random starting vector. --c --c input: --c m -- number of rows in a, as well as the number of rows in a2 --c n -- number of columns in a, as well as the number of columns --c in a2 --c matveca -- routine which applies the adjoint of a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matveca(m,x,n,y,p1a,p2a,p3a,p4a), --c --c where m is the length of x, --c x is the vector to which the adjoint of a --c is to be applied, --c n is the length of y, --c y is the product of the adjoint of a and x, --c and p1a, p2a, p3a, and p4a are user-specified --c parameters --c p1a -- parameter to be passed to routine matveca --c p2a -- parameter to be passed to routine matveca --c p3a -- parameter to be passed to routine matveca --c p4a -- parameter to be passed to routine matveca --c matveca2 -- routine which applies the adjoint of a2 --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matveca2(m,x,n,y,p1a2,p2a2,p3a2,p4a2), --c --c where m is the length of x, --c x is the vector to which the adjoint of a2 --c is to be applied, --c n is the length of y, --c y is the product of the adjoint of a2 and x, --c and p1a2, p2a2, p3a2, and p4a2 are user-specified --c parameters --c p1a2 -- parameter to be passed to routine matveca2 --c p2a2 -- parameter to be passed to routine matveca2 --c p3a2 -- parameter to be passed to routine matveca2 --c p4a2 -- parameter to be passed to routine matveca2 --c matvec -- routine which applies the matrix a --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which a is to be applied, --c m is the length of y, --c y is the product of a and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c matvec2 -- routine which applies the matrix a2 --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec2(n,x,m,y,p12,p22,p32,p42), --c --c where n is the length of x, --c x is the vector to which a2 is to be applied, --c m is the length of y, --c y is the product of a2 and x, and --c p12, p22, p32, and p42 are user-specified parameters --c p12 -- parameter to be passed to routine matvec2 --c p22 -- parameter to be passed to routine matvec2 --c p32 -- parameter to be passed to routine matvec2 --c p42 -- parameter to be passed to routine matvec2 --c its -- number of iterations of the power method to conduct --c --c output: --c snorm -- estimate of the spectral norm of a-a2 --c --c work: --c w -- must be at least 3*m+3*n complex*16 elements long --c --c reference: --c Kuczynski and Wozniakowski, "Estimating the largest eigenvalue --c by the power and Lanczos algorithms with a random start," --c SIAM Journal on Matrix Analysis and Applications, --c 13 (4): 1992, 1094-1122. --c -- implicit none -- integer m,n,its,lw,iu,lu,iu1,lu1,iu2,lu2, -- 1 iv,lv,iv1,lv1,iv2,lv2 -- real*8 snorm -- complex*16 p1a,p2a,p3a,p4a,p1a2,p2a2,p3a2,p4a2, -- 1 p1,p2,p3,p4,p12,p22,p32,p42,w(3*m+3*n) -- external matveca,matvec,matveca2,matvec2 --c --c --c Allocate memory in w. --c -- lw = 0 --c -- iu = lw+1 -- lu = m -- lw = lw+lu --c -- iu1 = lw+1 -- lu1 = m -- lw = lw+lu1 --c -- iu2 = lw+1 -- lu2 = m -- lw = lw+lu2 --c -- iv = lw+1 -- lv = n -- lw = lw+1 --c -- iv1 = lw+1 -- lv1 = n -- lw = lw+lv1 --c -- iv2 = lw+1 -- lv2 = n -- lw = lw+lv2 --c --c -- call idz_diffsnorm0(m,n,matveca,p1a,p2a,p3a,p4a, -- 1 matveca2,p1a2,p2a2,p3a2,p4a2, -- 2 matvec,p1,p2,p3,p4, -- 3 matvec2,p12,p22,p32,p42, -- 4 its,snorm,w(iu),w(iu1),w(iu2), -- 5 w(iv),w(iv1),w(iv2)) --c --c -- return -- end --c --c --c --c -- subroutine idz_diffsnorm0(m,n,matveca,p1a,p2a,p3a,p4a, -- 1 matveca2,p1a2,p2a2,p3a2,p4a2, -- 2 matvec,p1,p2,p3,p4, -- 3 matvec2,p12,p22,p32,p42, -- 4 its,snorm,u,u1,u2,v,v1,v2) --c --c routine idz_diffsnorm serves as a memory wrapper --c for the present routine. (Please see routine idz_diffsnorm --c for further documentation.) --c -- implicit none -- integer m,n,its,it,n2,k -- real*8 snorm,enorm -- complex*16 p1a,p2a,p3a,p4a,p1a2,p2a2,p3a2,p4a2, -- 1 p1,p2,p3,p4,p12,p22,p32,p42,u(m),u1(m),u2(m), -- 2 v(n),v1(n),v2(n) -- external matveca,matvec,matveca2,matvec2 --c --c --c Fill the real and imaginary parts of each entry --c of the initial vector v with i.i.d. random variables --c drawn uniformly from [-1,1]. --c -- n2 = 2*n -- call id_srand(n2,v) --c -- do k = 1,n -- v(k) = 2*v(k)-1 -- enddo ! k --c --c --c Normalize v. --c -- call idz_enorm(n,v,enorm) --c -- do k = 1,n -- v(k) = v(k)/enorm -- enddo ! k --c --c -- do it = 1,its --c --c Apply a and a2 to v, obtaining u1 and u2. --c -- call matvec(n,v,m,u1,p1,p2,p3,p4) -- call matvec2(n,v,m,u2,p12,p22,p32,p42) --c --c Form u = u1-u2. --c -- do k = 1,m -- u(k) = u1(k)-u2(k) -- enddo ! k --c --c Apply a^* and (a2)^* to u, obtaining v1 and v2. --c -- call matveca(m,u,n,v1,p1a,p2a,p3a,p4a) -- call matveca2(m,u,n,v2,p1a2,p2a2,p3a2,p4a2) --c --c Form v = v1-v2. --c -- do k = 1,n -- v(k) = v1(k)-v2(k) -- enddo ! k --c --c Normalize v. --c -- call idz_enorm(n,v,snorm) --c -- if(snorm .gt. 0) then --c -- do k = 1,n -- v(k) = v(k)/snorm -- enddo ! k --c -- endif --c -- snorm = sqrt(snorm) --c -- enddo ! it --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idz_svd.f b/scipy/linalg/src/id_dist/src/idz_svd.f -deleted file mode 100644 -index e14cf66a0..000000000 ---- a/scipy/linalg/src/id_dist/src/idz_svd.f -+++ /dev/null -@@ -1,438 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzr_svd computes an approximation of specified rank --c to a given matrix, in the usual SVD form U S V^*, --c where U has orthonormal columns, V has orthonormal columns, --c and S is diagonal. --c --c routine idzp_svd computes an approximation of specified --c precision to a given matrix, in the usual SVD form U S V^*, --c where U has orthonormal columns, V has orthonormal columns, --c and S is diagonal. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzr_svd(m,n,a,krank,u,v,s,ier,r) --c --c constructs a rank-krank SVD u diag(s) v^* approximating a, --c where u is an m x krank matrix whose columns are orthonormal, --c v is an n x krank matrix whose columns are orthonormal, --c and diag(s) is a diagonal krank x krank matrix whose entries --c are all nonnegative. This routine combines a QR code --c (which is based on plane/Householder reflections) --c with the LAPACK routine zgesdd. --c --c input: --c m -- first dimension of a and u --c n -- second dimension of a, and first dimension of v --c a -- matrix to be SVD'd --c krank -- desired rank of the approximation to a --c --c output: --c u -- left singular vectors of a corresponding --c to the k greatest singular values of a --c v -- right singular vectors of a corresponding --c to the k greatest singular values of a --c s -- k greatest singular values of a --c ier -- 0 when the routine terminates successfully; --c nonzero when the routine encounters an error --c --c work: --c r -- must be at least --c (krank+2)*n+8*min(m,n)+6*krank**2+8*krank --c complex*16 elements long --c --c _N.B._: This routine destroys a. Also, please beware that --c the source code for this routine could be clearer. --c -- implicit none -- character*1 jobz -- integer m,n,k,krank,ifadjoint,ldr,ldu,ldvadj,lwork, -- 1 info,j,ier,io -- real*8 s(krank) -- complex*16 a(m,n),u(m,krank),v(n*krank),r(*) --c --c -- io = 8*min(m,n) --c --c -- ier = 0 --c --c --c Compute a pivoted QR decomposition of a. --c -- call idzr_qrpiv(m,n,a,krank,r,r(io+1)) --c --c --c Extract R from the QR decomposition. --c -- call idz_retriever(m,n,a,krank,r(io+1)) --c --c --c Rearrange R according to ind. --c -- call idz_permuter(krank,r,krank,n,r(io+1)) --c --c --c Use LAPACK to SVD r, --c storing the krank (krank x 1) left singular vectors --c in r(io+krank*n+1 : io+krank*n+krank*krank). --c -- jobz = 'S' -- ldr = krank -- lwork = 2*(krank**2+2*krank+n) -- ldu = krank -- ldvadj = krank --c -- call zgesdd(jobz,krank,n,r(io+1),ldr,s,r(io+krank*n+1),ldu, -- 1 v,ldvadj,r(io+krank*n+krank*krank+1),lwork, -- 2 r(io+krank*n+krank*krank+lwork+1),r,info) --c -- if(info .ne. 0) then -- ier = info -- return -- endif --c --c --c Multiply the U from R from the left by Q to obtain the U --c for A. --c -- do k = 1,krank --c -- do j = 1,krank -- u(j,k) = r(io+krank*n+j+krank*(k-1)) -- enddo ! j --c -- do j = krank+1,m -- u(j,k) = 0 -- enddo ! j --c -- enddo ! k --c -- ifadjoint = 0 -- call idz_qmatmat(ifadjoint,m,n,a,krank,krank,u,r) --c --c --c Take the adjoint of v to obtain r. --c -- call idz_adjer(krank,n,v,r) --c --c --c Copy r into v. --c -- do k = 1,n*krank -- v(k) = r(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idzp_svd(lw,eps,m,n,a,krank,iu,iv,is,w,ier) --c --c constructs a rank-krank SVD U Sigma V^* approximating a --c to precision eps, where U is an m x krank matrix whose --c columns are orthonormal, V is an n x krank matrix whose --c columns are orthonormal, and Sigma is a diagonal krank x krank --c matrix whose entries are all nonnegative. --c The entries of U are stored in w, starting at w(iu); --c the entries of V are stored in w, starting at w(iv). --c The diagonal entries of Sigma are stored in w, --c starting at w(is). This routine combines a QR code --c (which is based on plane/Householder reflections) --c with the LAPACK routine zgesdd. --c --c input: --c lw -- maximum usable length of w (in complex*16 elements) --c eps -- precision to which the SVD approximates a --c m -- first dimension of a and u --c n -- second dimension of a, and first dimension of v --c a -- matrix to be SVD'd --c --c output: --c krank -- rank of the approximation to a --c iu -- index in w of the first entry of the matrix --c of orthonormal left singular vectors of a --c iv -- index in w of the first entry of the matrix --c of orthonormal right singular vectors of a --c is -- index in w of the first entry of the array --c of singular values of a; the singular values are stored --c as complex*16 numbers whose imaginary parts are zeros --c w -- array containing the singular values and singular vectors --c of a; w doubles as a work array, and so must be at least --c (krank+1)*(m+2*n+9)+8*min(m,n)+6*krank**2 --c complex*16 elements long, where krank is the rank --c output by the present routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lw is too small; --c other nonzero values when zgesdd bombs --c --c _N.B._: This routine destroys a. Also, please beware that --c the source code for this routine could be clearer. --c w must be at least --c (krank+1)*(m+2*n+9)+8*min(m,n)+6*krank**2 --c complex*16 elements long, where krank is the rank --c output by the present routine. --c -- implicit none -- character*1 jobz -- integer m,n,k,krank,ifadjoint,ldr,ldu,ldvadj,lwork, -- 1 info,j,ier,io,iu,iv,is,ivi,isi,lu,lv,ls,lw -- real*8 eps -- complex*16 a(m,n),w(*) --c --c -- io = 8*min(m,n) --c --c -- ier = 0 --c --c --c Compute a pivoted QR decomposition of a. --c -- call idzp_qrpiv(eps,m,n,a,krank,w,w(io+1)) --c --c -- if(krank .gt. 0) then --c --c --c Extract R from the QR decomposition. --c -- call idz_retriever(m,n,a,krank,w(io+1)) --c --c --c Rearrange R according to ind. --c -- call idz_permuter(krank,w,krank,n,w(io+1)) --c --c --c Use LAPACK to SVD R, --c storing the krank (krank x 1) left singular vectors --c in w(io+krank*n+1 : io+krank*n+krank*krank). --c -- jobz = 'S' -- ldr = krank -- lwork = 2*(krank**2+2*krank+n) -- ldu = krank -- ldvadj = krank --c -- ivi = io+krank*n+krank*krank+lwork+3*krank**2+4*krank+1 -- lv = n*krank --c -- isi = ivi+lv -- ls = krank --c -- if(lw .lt. isi+ls+m*krank-1) then -- ier = -1000 -- return -- endif --c -- call zgesdd(jobz,krank,n,w(io+1),ldr,w(isi),w(io+krank*n+1), -- 1 ldu,w(ivi),ldvadj,w(io+krank*n+krank*krank+1), -- 2 lwork,w(io+krank*n+krank*krank+lwork+1),w,info) --c -- if(info .ne. 0) then -- ier = info -- return -- endif --c --c --c Take the adjoint of w(ivi:ivi+lv-1) to obtain V. --c -- iv = 1 -- call idz_adjer(krank,n,w(ivi),w(iv)) --c --c --c Copy w(isi:isi+ls/2) into w(is:is+ls-1). --c -- is = iv+lv --c -- call idz_realcomp(ls,w(isi),w(is)) --c --c --c Multiply the U from R from the left by Q to obtain the U --c for A. --c -- iu = is+ls -- lu = m*krank --c -- do k = 1,krank --c -- do j = 1,krank -- w(iu-1+j+krank*(k-1)) = w(io+krank*n+j+krank*(k-1)) -- enddo ! j --c -- enddo ! k --c -- do k = krank,1,-1 --c -- do j = m,krank+1,-1 -- w(iu-1+j+m*(k-1)) = 0 -- enddo ! j --c -- do j = krank,1,-1 -- w(iu-1+j+m*(k-1)) = w(iu-1+j+krank*(k-1)) -- enddo ! j --c -- enddo ! k --c -- ifadjoint = 0 -- call idz_qmatmat(ifadjoint,m,n,a,krank,krank,w(iu), -- 1 w(iu+lu+1)) --c --c -- endif ! krank .gt. 0 --c --c -- return -- end --c --c --c --c -- subroutine idz_realcomp(n,a,b) --c --c copies the real*8 array a into the complex*16 array b. --c --c input: --c n -- length of a and b --c a -- real*8 array to be copied into b --c --c output: --c b -- complex*16 copy of a --c -- integer n,k -- real*8 a(n) -- complex*16 b(n) --c --c -- do k = 1,n -- b(k) = a(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_permuter(krank,ind,m,n,a) --c --c permutes the columns of a according to ind obtained --c from routine idzr_qrpiv or idzp_qrpiv, assuming that --c a = q r from idzr_qrpiv or idzp_qrpiv. --c --c input: --c krank -- rank specified to routine idzr_qrpiv --c or obtained from routine idzp_qrpiv --c ind -- indexing array obtained from routine idzr_qrpiv --c or idzp_qrpiv --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix to be rearranged --c --c output: --c a -- rearranged matrix --c -- implicit none -- integer k,krank,m,n,j,ind(krank) -- complex*16 cswap,a(m,n) --c --c -- do k = krank,1,-1 -- do j = 1,m --c -- cswap = a(j,k) -- a(j,k) = a(j,ind(k)) -- a(j,ind(k)) = cswap --c -- enddo ! j -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_retriever(m,n,a,krank,r) --c --c extracts R in the QR decomposition specified by the output a --c of the routine idzr_qrpiv or idzp_qrpiv --c --c input: --c m -- first dimension of a --c n -- second dimension of a and r --c a -- output of routine idzr_qrpiv or idzp_qrpiv --c krank -- rank specified to routine idzr_qrpiv, --c or output by routine idzp_qrpiv --c --c output: --c r -- triangular factor in the QR decomposition specified --c by the output a of the routine idzr_qrpiv or idzp_qrpiv --c -- implicit none -- integer m,n,j,k,krank -- complex*16 a(m,n),r(krank,n) --c --c --c Copy a into r and zero out the appropriate --c Householder vectors that are stored in one triangle of a. --c -- do k = 1,n -- do j = 1,krank -- r(j,k) = a(j,k) -- enddo ! j -- enddo ! k --c -- do k = 1,n -- if(k .lt. krank) then -- do j = k+1,krank -- r(j,k) = 0 -- enddo ! j -- endif -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idz_adjer(m,n,a,aa) --c --c forms the adjoint aa of a. --c --c input: --c m -- first dimension of a and second dimension of aa --c n -- second dimension of a and first dimension of aa --c a -- matrix whose adjoint is to be taken --c --c output: --c aa -- adjoint of a --c -- implicit none -- integer m,n,j,k -- complex*16 a(m,n),aa(n,m) --c --c -- do k = 1,n -- do j = 1,m -- aa(k,j) = conjg(a(j,k)) -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzp_aid.f b/scipy/linalg/src/id_dist/src/idzp_aid.f -deleted file mode 100644 -index 784b40cde..000000000 ---- a/scipy/linalg/src/id_dist/src/idzp_aid.f -+++ /dev/null -@@ -1,390 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzp_aid computes the ID, to a specified precision, --c of an arbitrary matrix. This routine is randomized. --c --c routine idz_estrank estimates the numerical rank, --c to a specified precision, of an arbitrary matrix. --c This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzp_aid(eps,m,n,a,work,krank,list,proj) --c --c computes the ID of the matrix a, i.e., lists in list --c the indices of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon dimensioned epsilon(m,n-krank) --c such that the greatest singular value of epsilon --c <= the greatest singular value of a * eps. --c --c input: --c eps -- precision to which the ID is to be computed --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix to be decomposed; the present routine does not --c alter a --c work -- initialization array that has been constructed --c by routine idz_frmi --c --c output: --c krank -- numerical rank of a to precision eps --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd; --c proj doubles as a work array in the present routine, so --c proj must be at least n*(2*n2+1)+n2+1 complex*16 --c elements long, where n2 is the greatest integer --c less than or equal to m, such that n2 is --c a positive integer power of two. --c --c _N.B._: The algorithm used by this routine is randomized. --c proj must be at least n*(2*n2+1)+n2+1 complex*16 --c elements long, where n2 is the greatest integer --c less than or equal to m, such that n2 is --c a positive integer power of two. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,list(n),krank,kranki,n2 -- real*8 eps -- complex*16 a(m,n),proj(*),work(17*m+70) --c --c --c Allocate memory in proj. --c -- n2 = work(2) --c --c --c Find the rank of a. --c -- call idz_estrank(eps,m,n,a,work,kranki,proj) --c --c -- if(kranki .eq. 0) call idzp_aid0(eps,m,n,a,krank,list,proj, -- 1 proj(m*n+1)) --c -- if(kranki .ne. 0) call idzp_aid1(eps,n2,n,kranki,proj, -- 1 krank,list,proj(n2*n+1)) --c --c -- return -- end --c --c --c --c -- subroutine idzp_aid0(eps,m,n,a,krank,list,proj,rnorms) --c --c uses routine idzp_id to ID a without modifying its entries --c (in contrast to the usual behavior of idzp_id). --c --c input: --c eps -- precision of the decomposition to be constructed --c m -- first dimension of a --c n -- second dimension of a --c --c output: --c krank -- numerical rank of the ID --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns in a; --c proj doubles as a work array in the present routine, so --c must be at least m*n complex*16 elements long --c --c work: --c rnorms -- must be at least n real*8 elements long --c --c _N.B._: proj must be at least m*n complex*16 elements long --c -- implicit none -- integer m,n,krank,list(n),j,k -- real*8 eps,rnorms(n) -- complex*16 a(m,n),proj(m,n) --c --c --c Copy a into proj. --c -- do k = 1,n -- do j = 1,m -- proj(j,k) = a(j,k) -- enddo ! j -- enddo ! k --c --c --c ID proj. --c -- call idzp_id(eps,m,n,proj,krank,list,rnorms) --c --c -- return -- end --c --c --c --c -- subroutine idzp_aid1(eps,n2,n,kranki,proj,krank,list,rnorms) --c --c IDs the uppermost kranki x n block of the n2 x n matrix --c input as proj. --c --c input: --c eps -- precision of the decomposition to be constructed --c n2 -- first dimension of proj as input --c n -- second dimension of proj as input --c kranki -- number of rows to extract from proj --c proj -- matrix containing the kranki x n block to be ID'd --c --c output: --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd --c krank -- numerical rank of the ID --c list -- indices of the columns in the ID --c --c work: --c rnorms -- must be at least n real*8 elements long --c -- implicit none -- integer n,n2,kranki,krank,list(n),j,k -- real*8 eps,rnorms(n) -- complex*16 proj(n2*n) --c --c --c Move the uppermost kranki x n block of the n2 x n matrix proj --c to the beginning of proj. --c -- do k = 1,n -- do j = 1,kranki -- proj(j+kranki*(k-1)) = proj(j+n2*(k-1)) -- enddo ! j -- enddo ! k --c --c --c ID proj. --c -- call idzp_id(eps,kranki,n,proj,krank,list,rnorms) --c --c -- return -- end --c --c --c --c -- subroutine idz_estrank(eps,m,n,a,w,krank,ra) --c --c estimates the numerical rank krank of an m x n matrix a --c to precision eps. This routine applies n2 random vectors --c to a, obtaining ra, where n2 is the greatest integer --c less than or equal to m such that n2 is a positive integer --c power of two. krank is typically about 8 higher than --c the actual numerical rank. --c --c input: --c eps -- precision defining the numerical rank --c m -- first dimension of a --c n -- second dimension of a --c a -- matrix whose rank is to be estimated --c w -- initialization array that has been constructed --c by routine idz_frmi --c --c output: --c krank -- estimate of the numerical rank of a; --c this routine returns krank = 0 when the actual --c numerical rank is nearly full (that is, --c greater than n - 8 or n2 - 8) --c ra -- product of an n2 x m random matrix and the m x n matrix --c a, where n2 is the greatest integer less than or equal --c to m such that n2 is a positive integer power of two; --c ra doubles as a work array in the present routine, and so --c must be at least n*n2+(n+1)*(n2+1) complex*16 elements --c long --c --c _N.B._: ra must be at least n*n2+(n2+1)*(n+1) complex*16 --c elements long for use in the present routine --c (here, n2 is the greatest integer less than or equal --c to m, such that n2 is a positive integer power of two). --c This routine returns krank = 0 when the actual --c numerical rank is nearly full. --c -- implicit none -- integer m,n,krank,n2,irat,lrat,iscal,lscal,ira,lra,lra2 -- real*8 eps -- complex*16 a(m,n),ra(*),w(17*m+70) --c --c --c Extract from the array w initialized by routine idz_frmi --c the greatest integer less than or equal to m that is --c a positive integer power of two. --c -- n2 = w(2) --c --c --c Allocate memory in ra. --c -- lra = 0 --c -- ira = lra+1 -- lra2 = n2*n -- lra = lra+lra2 --c -- irat = lra+1 -- lrat = n*(n2+1) -- lra = lra+lrat --c -- iscal = lra+1 -- lscal = n2+1 -- lra = lra+lscal --c -- call idz_estrank0(eps,m,n,a,w,n2,krank,ra(ira),ra(irat), -- 1 ra(iscal)) --c --c -- return -- end --c --c --c --c -- subroutine idz_estrank0(eps,m,n,a,w,n2,krank,ra,rat,scal) --c --c routine idz_estrank serves as a memory wrapper --c for the present routine. (Please see routine idz_estrank --c for further documentation.) --c -- implicit none -- integer m,n,n2,krank,ifrescal,k,nulls,j -- real*8 eps,scal(n2+1),ss,ssmax -- complex*16 a(m,n),ra(n2,n),residual,w(17*m+70),rat(n,n2+1) --c --c --c Apply the random matrix to every column of a, obtaining ra. --c -- do k = 1,n -- call idz_frm(m,n2,w,a(1,k),ra(1,k)) -- enddo ! k --c --c --c Compute the sum of squares of the entries in each column of ra --c and the maximum of all such sums. --c -- ssmax = 0 --c -- do k = 1,n --c -- ss = 0 -- do j = 1,m -- ss = ss+a(j,k)*conjg(a(j,k)) -- enddo ! j --c -- if(ss .gt. ssmax) ssmax = ss --c -- enddo ! k --c --c --c Transpose ra to obtain rat. --c -- call idz_transposer(n2,n,ra,rat) --c --c -- krank = 0 -- nulls = 0 --c --c --c Loop until nulls = 7, krank+nulls = n2, or krank+nulls = n. --c -- 1000 continue --c --c -- if(krank .gt. 0) then --c --c Apply the previous Householder transformations --c to rat(:,krank+1). --c -- ifrescal = 0 --c -- do k = 1,krank -- call idz_houseapp(n-k+1,rat(1,k),rat(k,krank+1), -- 1 ifrescal,scal(k),rat(k,krank+1)) -- enddo ! k --c -- endif ! krank .gt. 0 --c --c --c Compute the Householder vector associated --c with rat(krank+1:*,krank+1). --c -- call idz_house(n-krank,rat(krank+1,krank+1), -- 1 residual,rat(1,krank+1),scal(krank+1)) --c --c -- krank = krank+1 -- if(abs(residual) .le. eps*sqrt(ssmax)) nulls = nulls+1 --c --c -- if(nulls .lt. 7 .and. krank+nulls .lt. n2 -- 1 .and. krank+nulls .lt. n) -- 2 goto 1000 --c --c -- if(nulls .lt. 7) krank = 0 --c --c -- return -- end --c --c --c --c -- subroutine idz_transposer(m,n,a,at) --c --c transposes a to obtain at. --c --c input: --c m -- first dimension of a, and second dimension of at --c n -- second dimension of a, and first dimension of at --c a -- matrix to be transposed --c --c output: --c at -- transpose of a --c -- implicit none -- integer m,n,j,k -- complex*16 a(m,n),at(n,m) --c --c -- do k = 1,n -- do j = 1,m --c -- at(k,j) = a(j,k) --c -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzp_asvd.f b/scipy/linalg/src/id_dist/src/idzp_asvd.f -deleted file mode 100644 -index 4704f5bbd..000000000 ---- a/scipy/linalg/src/id_dist/src/idzp_asvd.f -+++ /dev/null -@@ -1,207 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzp_asvd computes the SVD, to a specified precision, --c of an arbitrary matrix. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzp_asvd(lw,eps,m,n,a,winit,krank,iu,iv,is,w,ier) --c --c constructs a rank-krank SVD U Sigma V^* approximating a --c to precision eps, where U is an m x krank matrix whose --c columns are orthonormal, V is an n x krank matrix whose --c columns are orthonormal, and Sigma is a diagonal krank x krank --c matrix whose entries are all nonnegative. --c The entries of U are stored in w, starting at w(iu); --c the entries of V are stored in w, starting at w(iv). --c The diagonal entries of Sigma are stored in w, --c starting at w(is). This routine uses a randomized algorithm. --c --c input: --c lw -- maximum usable length (in complex*16 elements) --c of the array w --c eps -- precision of the desired approximation --c m -- number of rows in a --c n -- number of columns in a --c a -- matrix to be approximated; the present routine does not --c alter a --c winit -- initialization array that has been constructed --c by routine idz_frmi --c --c output: --c krank -- rank of the SVD constructed --c iu -- index in w of the first entry of the matrix --c of orthonormal left singular vectors of a --c iv -- index in w of the first entry of the matrix --c of orthonormal right singular vectors of a --c is -- index in w of the first entry of the array --c of singular values of a --c w -- array containing the singular values and singular vectors --c of a; w doubles as a work array, and so must be at least --c max( (krank+1)*(3*m+5*n+11)+8*krank**2, (2*n+1)*(n2+1) ) --c complex*16 elements long, where n2 is the greatest integer --c less than or equal to m, such that n2 is --c a positive integer power of two; krank is the rank output --c by this routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lw is too small; --c other nonzero values when idz_id2svd bombs --c --c _N.B._: w must be at least --c max( (krank+1)*(3*m+5*n+11)+8*krank^2, (2*n+1)*(n2+1) ) --c complex*16 elements long, where n2 is --c the greatest integer less than or equal to m, --c such that n2 is a positive integer power of two; --c krank is the rank output by this routine. --c Also, the algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, -- 1 iwork,lwork,k,ier,lw2,iu,iv,is,iui,ivi,isi,lu,lv,ls -- real*8 eps -- complex*16 a(m,n),winit(17*m+70),w(*) --c --c --c Allocate memory in w. --c -- lw2 = 0 --c -- ilist = lw2+1 -- llist = n -- lw2 = lw2+llist --c -- iproj = lw2+1 --c --c --c ID a. --c -- call idzp_aid(eps,m,n,a,winit,krank,w(ilist),w(iproj)) --c --c -- if(krank .gt. 0) then --c --c --c Allocate more memory in w. --c -- lproj = krank*(n-krank) -- lw2 = lw2+lproj --c -- icol = lw2+1 -- lcol = m*krank -- lw2 = lw2+lcol --c -- iui = lw2+1 -- lu = m*krank -- lw2 = lw2+lu --c -- ivi = lw2+1 -- lv = n*krank -- lw2 = lw2+lv --c -- isi = lw2+1 -- ls = krank -- lw2 = lw2+ls --c -- iwork = lw2+1 -- lwork = (krank+1)*(m+3*n+10)+9*krank**2 -- lw2 = lw2+lwork --c --c -- if(lw .lt. lw2) then -- ier = -1000 -- return -- endif --c --c -- call idzp_asvd0(m,n,a,krank,w(ilist),w(iproj), -- 1 w(iui),w(ivi),w(isi),ier,w(icol),w(iwork)) -- if(ier .ne. 0) return --c --c -- iu = 1 -- iv = iu+lu -- is = iv+lv --c --c --c Copy the singular values and singular vectors --c into their proper locations. --c -- do k = 1,lu -- w(iu+k-1) = w(iui+k-1) -- enddo ! k --c -- do k = 1,lv -- w(iv+k-1) = w(ivi+k-1) -- enddo ! k --c -- call idz_realcomplex(ls,w(isi),w(is)) --c --c -- endif ! krank .gt. 0 --c --c -- return -- end --c --c --c --c -- subroutine idzp_asvd0(m,n,a,krank,list,proj,u,v,s,ier, -- 1 col,work) --c --c routine idzp_asvd serves as a memory wrapper --c for the present routine (please see routine idzp_asvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier -- real*8 s(krank) -- complex*16 a(m,n),u(m,krank),v(n,krank), -- 1 proj(krank,n-krank),col(m,krank), -- 2 work((krank+1)*(m+3*n+10)+9*krank**2) --c --c --c Collect together the columns of a indexed by list into col. --c -- call idz_copycols(m,n,a,krank,list,col) --c --c --c Convert the ID to an SVD. --c -- call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end --c --c --c --c -- subroutine idz_realcomplex(n,a,b) --c --c copies the real*8 array a into the complex*16 array b. --c --c input: --c n -- length of a and b --c a -- real*8 array to be copied into b --c --c output: --c b -- complex*16 copy of a --c -- integer n,k -- real*8 a(n) -- complex*16 b(n) --c --c -- do k = 1,n -- b(k) = a(k) -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzp_rid.f b/scipy/linalg/src/id_dist/src/idzp_rid.f -deleted file mode 100644 -index f12623aed..000000000 ---- a/scipy/linalg/src/id_dist/src/idzp_rid.f -+++ /dev/null -@@ -1,379 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzp_rid computes the ID, to a specified precision, --c of a matrix specified by a routine for applying its adjoint --c to arbitrary vectors. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzp_rid(lproj,eps,m,n,matveca,p1,p2,p3,p4, -- 1 krank,list,proj,ier) --c --c computes the ID of a, i.e., lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c krank --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank) (*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon dimensioned epsilon(m,n-krank) --c such that the greatest singular value of epsilon --c <= the greatest singular value of a * eps. --c --c input: --c lproj -- maximum usable length (in complex*16 elements) --c of the array proj --c eps -- precision to which the ID is to be computed --c m -- first dimension of a --c n -- second dimension of a --c matveca -- routine which applies the adjoint --c of the matrix to be ID'd to an arbitrary vector; --c this routine must have a calling sequence --c of the form --c --c matveca(m,x,n,y,p1,p2,p3,p4), --c --c where m is the length of x, --c x is the vector to which the adjoint --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the adjoint of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matveca --c p2 -- parameter to be passed to routine matveca --c p3 -- parameter to be passed to routine matveca --c p4 -- parameter to be passed to routine matveca --c --c output: --c krank -- numerical rank --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd; --c the present routine uses proj as a work array, too, so --c proj must be at least m+1 + 2*n*(krank+1) complex*16 --c elements long, where krank is the rank output --c by the present routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lproj is too small --c --c _N.B._: The algorithm used by this routine is randomized. --c proj must be at least m+1 + 2*n*(krank+1) complex*16 --c elements long, where krank is the rank output --c by the present routine. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,list(n),krank,lw,iwork,lwork,ira,kranki,lproj, -- 1 lra,ier,k -- real*8 eps -- complex*16 p1,p2,p3,p4,proj(*) -- external matveca --c --c -- ier = 0 --c --c --c Allocate memory in proj. --c -- lw = 0 --c -- iwork = lw+1 -- lwork = m+2*n+1 -- lw = lw+lwork --c -- ira = lw+1 --c --c --c Find the rank of a. --c -- lra = lproj-lwork -- call idz_findrank(lra,eps,m,n,matveca,p1,p2,p3,p4, -- 1 kranki,proj(ira),ier,proj(iwork)) -- if(ier .ne. 0) return --c --c -- if(lproj .lt. lwork+2*kranki*n) then -- ier = -1000 -- return -- endif --c --c --c Take the adjoint of ra. --c -- call idz_adjointer(n,kranki,proj(ira),proj(ira+kranki*n)) --c --c --c Move the adjoint thus obtained to the beginning of proj. --c -- do k = 1,kranki*n -- proj(k) = proj(ira+kranki*n+k-1) -- enddo ! k --c --c --c ID the adjoint. --c -- call idzp_id(eps,kranki,n,proj,krank,list,proj(1+kranki*n)) --c --c -- return -- end --c --c --c --c -- subroutine idz_findrank(lra,eps,m,n,matveca,p1,p2,p3,p4, -- 1 krank,ra,ier,w) --c --c estimates the numerical rank krank of a matrix a to precision --c eps, where the routine matveca applies the adjoint of a --c to an arbitrary vector. This routine applies the adjoint of a --c to krank random vectors, and returns the resulting vectors --c as the columns of ra. --c --c input: --c lra -- maximum usable length (in complex*16 elements) --c of array ra --c eps -- precision defining the numerical rank --c m -- first dimension of a --c n -- second dimension of a --c matveca -- routine which applies the adjoint --c of the matrix whose rank is to be estimated --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matveca(m,x,n,y,p1,p2,p3,p4), --c --c where m is the length of x, --c x is the vector to which the adjoint --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the adjoint of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matveca --c p2 -- parameter to be passed to routine matveca --c p3 -- parameter to be passed to routine matveca --c p4 -- parameter to be passed to routine matveca --c --c output: --c krank -- estimate of the numerical rank of a --c ra -- product of the adjoint of a and a matrix whose entries --c are pseudorandom realizations of i.i.d. random numbers, --c uniformly distributed on [0,1]; --c ra must be at least 2*n*krank complex*16 elements long --c ier -- 0 when the routine terminates successfully; --c -1000 when lra is too small --c --c work: --c w -- must be at least m+2*n+1 complex*16 elements long --c --c _N.B._: ra must be at least 2*n*krank complex*16 elements long. --c Also, the algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,lw,krank,ix,lx,iy,ly,iscal,lscal,lra,ier -- real*8 eps -- complex*16 p1,p2,p3,p4,ra(n,*),w(m+2*n+1) -- external matveca --c --c -- lw = 0 --c -- ix = lw+1 -- lx = m -- lw = lw+lx --c -- iy = lw+1 -- ly = n -- lw = lw+ly --c -- iscal = lw+1 -- lscal = n+1 -- lw = lw+lscal --c --c -- call idz_findrank0(lra,eps,m,n,matveca,p1,p2,p3,p4, -- 1 krank,ra,ier,w(ix),w(iy),w(iscal)) --c --c -- return -- end --c --c --c --c -- subroutine idz_findrank0(lra,eps,m,n,matveca,p1,p2,p3,p4, -- 1 krank,ra,ier,x,y,scal) --c --c routine idz_findrank serves as a memory wrapper --c for the present routine. (Please see routine idz_findrank --c for further documentation.) --c -- implicit none -- integer m,n,krank,ifrescal,k,lra,ier,m2 -- real*8 eps,enorm -- complex*16 x(m),ra(n,2,*),p1,p2,p3,p4,scal(n+1),y(n),residual -- external matveca --c --c -- ier = 0 --c --c -- krank = 0 --c --c --c Loop until the relative residual is greater than eps, --c or krank = m or krank = n. --c -- 1000 continue --c --c -- if(lra .lt. n*2*(krank+1)) then -- ier = -1000 -- return -- endif --c --c --c Apply the adjoint of a to a random vector. --c -- m2 = m*2 -- call id_srand(m2,x) -- call matveca(m,x,n,ra(1,1,krank+1),p1,p2,p3,p4) --c -- do k = 1,n -- y(k) = ra(k,1,krank+1) -- enddo ! k --c --c -- if(krank .eq. 0) then --c --c Compute the Euclidean norm of y. --c -- enorm = 0 --c -- do k = 1,n -- enorm = enorm + y(k)*conjg(y(k)) -- enddo ! k --c -- enorm = sqrt(enorm) --c -- endif ! krank .eq. 0 --c --c -- if(krank .gt. 0) then --c --c Apply the previous Householder transformations to y. --c -- ifrescal = 0 --c -- do k = 1,krank -- call idz_houseapp(n-k+1,ra(1,2,k),y(k), -- 1 ifrescal,scal(k),y(k)) -- enddo ! k --c -- endif ! krank .gt. 0 --c --c --c Compute the Householder vector associated with y. --c -- call idz_house(n-krank,y(krank+1), -- 1 residual,ra(1,2,krank+1),scal(krank+1)) --c --c -- krank = krank+1 --c --c -- if(abs(residual) .gt. eps*enorm -- 1 .and. krank .lt. m .and. krank .lt. n) -- 2 goto 1000 --c --c --c Delete the Householder vectors from the array ra. --c -- call idz_crunch(n,krank,ra) --c --c -- return -- end --c --c --c --c -- subroutine idz_crunch(n,l,a) --c --c removes every other block of n entries from a vector. --c --c input: --c n -- length of each block to remove --c l -- half of the total number of blocks --c a -- original array --c --c output: --c a -- array with every other block of n entries removed --c -- implicit none -- integer j,k,n,l -- complex*16 a(n,2*l) --c --c -- do j = 2,l -- do k = 1,n --c -- a(k,j) = a(k,2*j-1) --c -- enddo ! k -- enddo ! j --c --c -- return -- end --c --c --c --c -- subroutine idz_adjointer(m,n,a,aa) --c --c forms the adjoint aa of a. --c --c input: --c m -- first dimension of a, and second dimension of aa --c n -- second dimension of a, and first dimension of aa --c a -- matrix whose adjoint is to be taken --c --c output: --c aa -- adjoint of a --c -- implicit none -- integer m,n,j,k -- complex*16 a(m,n),aa(n,m) --c --c -- do k = 1,n -- do j = 1,m --c -- aa(k,j) = conjg(a(j,k)) --c -- enddo ! j -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzp_rsvd.f b/scipy/linalg/src/id_dist/src/idzp_rsvd.f -deleted file mode 100644 -index e34b3e374..000000000 ---- a/scipy/linalg/src/id_dist/src/idzp_rsvd.f -+++ /dev/null -@@ -1,244 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzp_rsvd computes the SVD, to a specified precision, --c of a matrix specified by routines for applying the matrix --c and its adjoint to arbitrary vectors. --c This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzp_rsvd(lw,eps,m,n,matveca,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,iu,iv,is,w,ier) --c --c constructs a rank-krank SVD U Sigma V^* approximating a --c to precision eps, where matveca is a routine which applies a^* --c to an arbitrary vector, and matvec is a routine --c which applies a to an arbitrary vector; U is an m x krank --c matrix whose columns are orthonormal, V is an n x krank --c matrix whose columns are orthonormal, and Sigma is a diagonal --c krank x krank matrix whose entries are all nonnegative. --c The entries of U are stored in w, starting at w(iu); --c the entries of V are stored in w, starting at w(iv). --c The diagonal entries of Sigma are stored in w, --c starting at w(is). This routine uses a randomized algorithm. --c --c input: --c lw -- maximum usable length (in complex*16 elements) --c of the array w --c eps -- precision of the desired approximation --c m -- number of rows in a --c n -- number of columns in a --c matveca -- routine which applies the adjoint --c of the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matveca(m,x,n,y,p1t,p2t,p3t,p4t), --c --c where m is the length of x, --c x is the vector to which the adjoint --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the adjoint of the matrix and x, --c and p1t, p2t, p3t, and p4t are user-specified --c parameters --c p1t -- parameter to be passed to routine matveca --c p2t -- parameter to be passed to routine matveca --c p3t -- parameter to be passed to routine matveca --c p4t -- parameter to be passed to routine matveca --c matvec -- routine which applies the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which the matrix is to be applied, --c m is the length of y, --c y is the product of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c --c output: --c krank -- rank of the SVD constructed --c iu -- index in w of the first entry of the matrix --c of orthonormal left singular vectors of a --c iv -- index in w of the first entry of the matrix --c of orthonormal right singular vectors of a --c is -- index in w of the first entry of the array --c of singular values of a; the singular values are stored --c as complex*16 numbers whose imaginary parts are zeros --c w -- array containing the singular values and singular vectors --c of a; w doubles as a work array, and so must be at least --c (krank+1)*(3*m+5*n+11)+8*krank^2 complex*16 elements long, --c where krank is the rank returned by the present routine --c ier -- 0 when the routine terminates successfully; --c -1000 when lw is too small; --c other nonzero values when idz_id2svd bombs --c --c _N.B._: w must be at least (krank+1)*(3*m+5*n+11)+8*krank**2 --c complex*16 elements long, where krank is the rank --c returned by the present routine. Also, the algorithm --c used by the present routine is randomized. --c -- implicit none -- integer m,n,krank,lw,lw2,ilist,llist,iproj,icol,lcol,lp, -- 1 iwork,lwork,ier,lproj,iu,iv,is,lu,lv,ls,iui,ivi,isi,k -- real*8 eps -- complex*16 p1t,p2t,p3t,p4t,p1,p2,p3,p4,w(*) -- external matveca,matvec --c --c --c Allocate some memory. --c -- lw2 = 0 --c -- ilist = lw2+1 -- llist = n -- lw2 = lw2+llist --c -- iproj = lw2+1 --c --c --c ID a. --c -- lp = lw-lw2 -- call idzp_rid(lp,eps,m,n,matveca,p1t,p2t,p3t,p4t,krank, -- 1 w(ilist),w(iproj),ier) -- if(ier .ne. 0) return --c --c -- if(krank .gt. 0) then --c --c --c Allocate more memory. --c -- lproj = krank*(n-krank) -- lw2 = lw2+lproj --c -- icol = lw2+1 -- lcol = m*krank -- lw2 = lw2+lcol --c -- iui = lw2+1 -- lu = m*krank -- lw2 = lw2+lu --c -- ivi = lw2+1 -- lv = n*krank -- lw2 = lw2+lv --c -- isi = lw2+1 -- ls = krank -- lw2 = lw2+ls --c -- iwork = lw2+1 -- lwork = (krank+1)*(m+3*n+10)+9*krank**2 -- lw2 = lw2+lwork --c --c -- if(lw .lt. lw2) then -- ier = -1000 -- return -- endif --c --c -- call idzp_rsvd0(m,n,matveca,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,w(iui),w(ivi), -- 2 w(isi),ier,w(ilist),w(iproj),w(icol), -- 3 w(iwork)) -- if(ier .ne. 0) return --c --c -- iu = 1 -- iv = iu+lu -- is = iv+lv --c --c --c Copy the singular values and singular vectors --c into their proper locations. --c -- do k = 1,lu -- w(iu+k-1) = w(iui+k-1) -- enddo ! k --c -- do k = 1,lv -- w(iv+k-1) = w(ivi+k-1) -- enddo ! k --c -- call idz_reco(ls,w(isi),w(is)) --c --c -- endif ! krank .gt. 0 --c --c -- return -- end --c --c --c --c -- subroutine idzp_rsvd0(m,n,matveca,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, -- 2 list,proj,col,work) --c --c routine idzp_rsvd serves as a memory wrapper --c for the present routine (please see routine idzp_rsvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier -- real*8 s(krank) -- complex*16 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), -- 1 proj(krank,n-krank),col(m*krank), -- 2 work((krank+1)*(m+3*n+10)+9*krank**2) -- external matveca,matvec --c --c --c Collect together the columns of a indexed by list into col. --c -- call idz_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work) --c --c --c Convert the ID to an SVD. --c -- call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end --c --c --c --c -- subroutine idz_reco(n,a,b) --c --c copies the real*8 array a into the complex*16 array b. --c --c input: --c n -- length of a and b --c a -- real*8 array to be copied into b --c --c output: --c b -- complex*16 copy of a --c -- integer n,k -- real*8 a(n) -- complex*16 b(n) --c --c -- do k = 1,n -- b(k) = a(k) -- enddo ! k --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzr_aid.f b/scipy/linalg/src/id_dist/src/idzr_aid.f -deleted file mode 100644 -index e8380ecd3..000000000 ---- a/scipy/linalg/src/id_dist/src/idzr_aid.f -+++ /dev/null -@@ -1,209 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzr_aid computes the ID, to a specified rank, --c of an arbitrary matrix. This routine is randomized. --c --c routine idzr_aidi initializes routine idzr_aid. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzr_aid(m,n,a,krank,w,list,proj) --c --c computes the ID of the matrix a, i.e., lists in list --c the indices of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c min(m,n,krank) --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon, dimensioned epsilon(m,n-krank), --c whose norm is (hopefully) minimized by the pivoting procedure. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c a -- matrix to be ID'd; the present routine does not alter a --c krank -- rank of the ID to be constructed --c w -- initialization array that routine idzr_aidi --c has constructed --c --c output: --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd --c --c _N.B._: The algorithm used by this routine is randomized. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,krank,list(n),lw,ir,lr,lw2,iw -- complex*16 a(m,n),proj(krank*(n-krank)), -- 1 w((2*krank+17)*n+21*m+80) --c --c --c Allocate memory in w. --c -- lw = 0 --c -- iw = lw+1 -- lw2 = 21*m+80+n -- lw = lw+lw2 --c -- ir = lw+1 -- lr = (krank+8)*2*n -- lw = lw+lr --c --c -- call idzr_aid0(m,n,a,krank,w(iw),list,proj,w(ir)) --c --c -- return -- end --c --c --c --c -- subroutine idzr_aid0(m,n,a,krank,w,list,proj,r) --c --c routine idzr_aid serves as a memory wrapper --c for the present routine --c (see idzr_aid for further documentation). --c -- implicit none -- integer k,l,m,n2,n,krank,list(n),mn,lproj -- complex*16 a(m,n),r(krank+8,2*n),proj(krank,n-krank), -- 1 w(21*m+80+n) --c --c Please note that the second dimension of r is 2*n --c (instead of n) so that if krank+8 >= m/2, then --c we can copy the whole of a into r. --c --c --c Retrieve the number of random test vectors --c and the greatest integer less than m that is --c a positive integer power of two. --c -- l = w(1) -- n2 = w(2) --c --c -- if(l .lt. n2 .and. l .le. m) then --c --c Apply the random matrix. --c -- do k = 1,n -- call idz_sfrm(l,m,n2,w(11),a(1,k),r(1,k)) -- enddo ! k --c --c ID r. --c -- call idzr_id(l,n,r,krank,list,w(20*m+81)) --c --c Retrieve proj from r. --c -- lproj = krank*(n-krank) -- call idzr_copyzarr(lproj,r,proj) --c -- endif --c --c -- if(l .ge. n2 .or. l .gt. m) then --c --c ID a directly. --c -- mn = m*n -- call idzr_copyzarr(mn,a,r) -- call idzr_id(m,n,r,krank,list,w(20*m+81)) --c --c Retrieve proj from r. --c -- lproj = krank*(n-krank) -- call idzr_copyzarr(lproj,r,proj) --c -- endif --c --c -- return -- end --c --c --c --c -- subroutine idzr_copyzarr(n,a,b) --c --c copies a into b. --c --c input: --c n -- length of a and b --c a -- array to copy into b --c --c output: --c b -- copy of a --c -- implicit none -- integer n,k -- complex*16 a(n),b(n) --c --c -- do k = 1,n -- b(k) = a(k) -- enddo ! k --c --c -- return -- end --c --c --c --c -- subroutine idzr_aidi(m,n,krank,w) --c --c initializes the array w for using routine idzr_aid. --c --c input: --c m -- number of rows in the matrix to be ID'd --c n -- number of columns in the matrix to be ID'd --c krank -- rank of the ID to be constructed --c --c output: --c w -- initialization array for using routine idzr_aid --c -- implicit none -- integer m,n,krank,l,n2 -- complex*16 w((2*krank+17)*n+21*m+80) --c --c --c Set the number of random test vectors to 8 more than the rank. --c -- l = krank+8 -- w(1) = l --c --c --c Initialize the rest of the array w. --c -- n2 = 0 -- if(l .le. m) call idz_sfrmi(l,m,n2,w(11)) -- w(2) = n2 --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzr_asvd.f b/scipy/linalg/src/id_dist/src/idzr_asvd.f -deleted file mode 100644 -index 55ad61203..000000000 ---- a/scipy/linalg/src/id_dist/src/idzr_asvd.f -+++ /dev/null -@@ -1,118 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzr_aid computes the SVD, to a specified rank, --c of an arbitrary matrix. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzr_asvd(m,n,a,krank,w,u,v,s,ier) --c --c constructs a rank-krank SVD u diag(s) v^* approximating a, --c where u is an m x krank matrix whose columns are orthonormal, --c v is an n x krank matrix whose columns are orthonormal, --c and diag(s) is a diagonal krank x krank matrix whose entries --c are all nonnegative. This routine uses a randomized algorithm. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c a -- matrix to be decomposed; the present routine does not --c alter a --c krank -- rank of the SVD being constructed --c w -- initialization array that routine idzr_aidi --c has constructed (for use in the present routine, --c w must be at least --c (2*krank+22)*m+(6*krank+21)*n+8*krank**2+10*krank+90 --c complex*16 elements long) --c --c output: --c u -- matrix of orthonormal left singular vectors of a --c v -- matrix of orthonormal right singular vectors of a --c s -- array of singular values of a --c ier -- 0 when the routine terminates successfully; --c nonzero otherwise --c --c _N.B._: The algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, -- 1 iwork,lwork,iwinit,lwinit,ier -- real*8 s(krank) -- complex*16 a(m,n),u(m,krank),v(n,krank), -- 1 w((2*krank+22)*m+(6*krank+21)*n+8*krank**2 -- 2 +10*krank+90) --c --c --c Allocate memory in w. --c -- lw = 0 --c -- iwinit = lw+1 -- lwinit = (2*krank+17)*n+21*m+80 -- lw = lw+lwinit --c -- ilist = lw+1 -- llist = n -- lw = lw+llist --c -- iproj = lw+1 -- lproj = krank*(n-krank) -- lw = lw+lproj --c -- icol = lw+1 -- lcol = m*krank -- lw = lw+lcol --c -- iwork = lw+1 -- lwork = (krank+1)*(m+3*n+10)+9*krank**2 -- lw = lw+lwork --c --c -- call idzr_asvd0(m,n,a,krank,w(iwinit),u,v,s,ier, -- 1 w(ilist),w(iproj),w(icol),w(iwork)) --c --c -- return -- end --c --c --c --c -- subroutine idzr_asvd0(m,n,a,krank,winit,u,v,s,ier, -- 1 list,proj,col,work) --c --c routine idzr_asvd serves as a memory wrapper --c for the present routine (please see routine idzr_asvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier -- real*8 s(krank) -- complex*16 a(m,n),u(m,krank),v(n,krank), -- 1 proj(krank,n-krank),col(m*krank), -- 2 winit((2*krank+17)*n+21*m+80), -- 3 work((krank+1)*(m+3*n+10)+9*krank**2) --c --c --c ID a. --c -- call idzr_aid(m,n,a,krank,winit,list,proj) --c --c --c Collect together the columns of a indexed by list into col. --c -- call idz_copycols(m,n,a,krank,list,col) --c --c --c Convert the ID to an SVD. --c -- call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzr_rid.f b/scipy/linalg/src/id_dist/src/idzr_rid.f -deleted file mode 100644 -index cf8fcaacf..000000000 ---- a/scipy/linalg/src/id_dist/src/idzr_rid.f -+++ /dev/null -@@ -1,156 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzr_rid computes the ID, to a specified rank, --c of a matrix specified by a routine for applying its adjoint --c to arbitrary vectors. This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzr_rid(m,n,matveca,p1,p2,p3,p4,krank,list,proj) --c --c computes the ID of a matrix "a" specified by --c the routine matveca -- matveca must apply the adjoint --c of the matrix being ID'd to an arbitrary vector -- --c i.e., the present routine lists in list the indices --c of krank columns of a such that --c --c a(j,list(k)) = a(j,list(k)) --c --c for all j = 1, ..., m; k = 1, ..., krank, and --c --c min(m,n,krank) --c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) --c l=1 --c --c + epsilon(j,k-krank) --c --c for all j = 1, ..., m; k = krank+1, ..., n, --c --c for some matrix epsilon, dimensioned epsilon(m,n-krank), --c whose norm is (hopefully) minimized by the pivoting procedure. --c --c input: --c m -- number of rows in the matrix to be ID'd --c n -- number of columns in the matrix to be ID'd --c matveca -- routine which applies the adjoint --c of the matrix to be ID'd to an arbitrary vector; --c this routine must have a calling sequence --c of the form --c --c matveca(m,x,n,y,p1,p2,p3,p4), --c --c where m is the length of x, --c x is the vector to which the adjoint --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the adjoint of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matveca --c p2 -- parameter to be passed to routine matveca --c p3 -- parameter to be passed to routine matveca --c p4 -- parameter to be passed to routine matveca --c krank -- rank of the ID to be constructed --c --c output: --c list -- indices of the columns in the ID --c proj -- matrix of coefficients needed to interpolate --c from the selected columns to the other columns --c in the original matrix being ID'd; --c proj doubles as a work array in the present routine, so --c proj must be at least m+(krank+3)*n complex*16 elements --c long --c --c _N.B._: The algorithm used by this routine is randomized. --c proj must be at least m+(krank+3)*n complex*16 elements --c long. --c --c reference: --c Halko, Martinsson, Tropp, "Finding structure with randomness: --c probabilistic algorithms for constructing approximate --c matrix decompositions," SIAM Review, 53 (2): 217-288, --c 2011. --c -- implicit none -- integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr -- complex*16 p1,p2,p3,p4,proj(m+(krank+3)*n) -- external matveca --c --c --c Allocate memory in w. --c -- lw = 0 --c -- ir = lw+1 -- lr = (krank+2)*n -- lw = lw+lr --c -- ix = lw+1 -- lx = m -- lw = lw+lx --c -- iy = lw+1 -- ly = n -- lw = lw+ly --c --c -- call idzr_ridall0(m,n,matveca,p1,p2,p3,p4,krank, -- 1 list,proj(ir),proj(ix),proj(iy)) --c --c -- return -- end --c --c --c --c -- subroutine idzr_ridall0(m,n,matveca,p1,p2,p3,p4,krank, -- 1 list,r,x,y) --c --c routine idzr_ridall serves as a memory wrapper --c for the present routine --c (see idzr_ridall for further documentation). --c -- implicit none -- integer j,k,l,m,n,krank,list(n),m2 -- complex*16 x(m),y(n),p1,p2,p3,p4,r(krank+2,n) -- external matveca --c --c --c Set the number of random test vectors to 2 more than the rank. --c -- l = krank+2 --c --c Apply the adjoint of the original matrix to l random vectors. --c -- do j = 1,l --c --c Generate a random vector. --c -- m2 = m*2 -- call id_srand(m2,x) --c --c Apply the adjoint of the matrix to x, obtaining y. --c -- call matveca(m,x,n,y,p1,p2,p3,p4) --c --c Copy the conjugate of y into row j of r. --c -- do k = 1,n -- r(j,k) = conjg(y(k)) -- enddo ! k --c -- enddo ! j --c --c --c ID r. --c -- call idzr_id(l,n,r,krank,list,y) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/idzr_rsvd.f b/scipy/linalg/src/id_dist/src/idzr_rsvd.f -deleted file mode 100644 -index d788e219b..000000000 ---- a/scipy/linalg/src/id_dist/src/idzr_rsvd.f -+++ /dev/null -@@ -1,159 +0,0 @@ --c this file contains the following user-callable routines: --c --c --c routine idzr_rsvd computes the SVD, to a specified rank, --c of a matrix specified by routines for applying the matrix --c and its adjoint to arbitrary vectors. --c This routine is randomized. --c --c --ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc --c --c --c --c -- subroutine idzr_rsvd(m,n,matveca,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier,w) --c --c constructs a rank-krank SVD u diag(s) v^* approximating a, --c where matveca is a routine which applies a^* --c to an arbitrary vector, and matvec is a routine --c which applies a to an arbitrary vector; --c u is an m x krank matrix whose columns are orthonormal, --c v is an n x krank matrix whose columns are orthonormal, --c and diag(s) is a diagonal krank x krank matrix whose entries --c are all nonnegative. This routine uses a randomized algorithm. --c --c input: --c m -- number of rows in a --c n -- number of columns in a --c matveca -- routine which applies the adjoint --c of the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matveca(m,x,n,y,p1t,p2t,p3t,p4t), --c --c where m is the length of x, --c x is the vector to which the adjoint --c of the matrix is to be applied, --c n is the length of y, --c y is the product of the adjoint of the matrix and x, --c and p1t, p2t, p3t, and p4t are user-specified --c parameters --c p1t -- parameter to be passed to routine matveca --c p2t -- parameter to be passed to routine matveca --c p3t -- parameter to be passed to routine matveca --c p4t -- parameter to be passed to routine matveca --c matvec -- routine which applies the matrix to be SVD'd --c to an arbitrary vector; this routine must have --c a calling sequence of the form --c --c matvec(n,x,m,y,p1,p2,p3,p4), --c --c where n is the length of x, --c x is the vector to which the matrix is to be applied, --c m is the length of y, --c y is the product of the matrix and x, --c and p1, p2, p3, and p4 are user-specified parameters --c p1 -- parameter to be passed to routine matvec --c p2 -- parameter to be passed to routine matvec --c p3 -- parameter to be passed to routine matvec --c p4 -- parameter to be passed to routine matvec --c krank -- rank of the SVD being constructed --c --c output: --c u -- matrix of orthonormal left singular vectors of a --c v -- matrix of orthonormal right singular vectors of a --c s -- array of singular values of a --c ier -- 0 when the routine terminates successfully; --c nonzero otherwise --c --c work: --c w -- must be at least (krank+1)*(2*m+4*n+10)+8*krank**2 --c complex*16 elements long --c --c _N.B._: The algorithm used by this routine is randomized. --c -- implicit none -- integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, -- 1 iwork,lwork,ier -- real*8 s(krank) -- complex*16 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), -- 1 w((krank+1)*(2*m+4*n+10)+8*krank**2) -- external matveca,matvec --c --c --c Allocate memory in w. --c -- lw = 0 --c -- ilist = lw+1 -- llist = n -- lw = lw+llist --c -- iproj = lw+1 -- lproj = krank*(n-krank) -- lw = lw+lproj --c -- icol = lw+1 -- lcol = m*krank -- lw = lw+lcol --c -- iwork = lw+1 -- lwork = (krank+1)*(m+3*n+10)+9*krank**2 -- lw = lw+lwork --c --c -- call idzr_rsvd0(m,n,matveca,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, -- 2 w(ilist),w(iproj),w(icol),w(iwork)) --c --c -- return -- end --c --c --c --c -- subroutine idzr_rsvd0(m,n,matveca,p1t,p2t,p3t,p4t, -- 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, -- 2 list,proj,col,work) --c --c routine idzr_rsvd serves as a memory wrapper --c for the present routine (please see routine idzr_rsvd --c for further documentation). --c -- implicit none -- integer m,n,krank,list(n),ier,k -- real*8 s(krank) -- complex*16 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), -- 1 proj(krank*(n-krank)),col(m*krank), -- 2 work((krank+1)*(m+3*n+10)+9*krank**2) -- external matveca,matvec --c --c --c ID a. --c -- call idzr_rid(m,n,matveca,p1t,p2t,p3t,p4t,krank,list,work) --c --c --c Retrieve proj from work. --c -- do k = 1,krank*(n-krank) -- proj(k) = work(k) -- enddo ! k --c --c --c Collect together the columns of a indexed by list into col. --c -- call idz_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work) --c --c --c Convert the ID to an SVD. --c -- call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) --c --c -- return -- end -diff --git a/scipy/linalg/src/id_dist/src/prini.f b/scipy/linalg/src/id_dist/src/prini.f -deleted file mode 100644 -index 679590d84..000000000 ---- a/scipy/linalg/src/id_dist/src/prini.f -+++ /dev/null -@@ -1,113 +0,0 @@ --C --C --C --C -- SUBROUTINE PRINI(IP1,IQ1) -- save -- CHARACTER *1 MES(1), AA(1) -- REAL *4 A(1) -- REAL *8 A2(1) -- REAL *8 A4(1) -- INTEGER *4 IA(1) -- INTEGER *2 IA2(1) -- IP=IP1 -- IQ=IQ1 -- -- RETURN -- --C --C --C --C --C -- ENTRY PRIN(MES,A,N) -- CALL MESSPR(MES,IP,IQ) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1200)(A(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1200)(A(J),J=1,N) -- 1200 FORMAT(6(2X,E11.5)) -- RETURN --C --C --C --C -- ENTRY PRIN2(MES,A2,N) -- CALL MESSPR(MES,IP,IQ) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1400)(A2(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1400)(A2(J),J=1,N) -- 1400 FORMAT(6(2X,E11.5)) -- RETURN --C --C --C --C -- ENTRY PRIN2_long(MES,A2,N) -- CALL MESSPR(MES,IP,IQ) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1450)(A2(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1450)(A2(J),J=1,N) -- 1450 FORMAT(2(2X,E22.16)) -- RETURN --C --C --C --C -- ENTRY PRINQ(MES,A4,N) -- CALL MESSPR(MES,IP,IQ) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1500)(A4(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1500)(A4(J),J=1,N) -- 1500 FORMAT(6(2X,e11.5)) -- RETURN --C --C --C --C -- ENTRY PRINF(MES,IA,N) -- CALL MESSPR(MES,IP,IQ) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1600)(IA(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1600)(IA(J),J=1,N) -- 1600 FORMAT(10(1X,I7)) -- RETURN --C --C --C --C -- ENTRY PRINF2(MES,IA2,N) -- CALL MESSPR(MES,IP,IQ) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1600)(IA2(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1600)(IA2(J),J=1,N) -- RETURN --C --C --C --C -- ENTRY PRINA(MES,AA,N) -- CALL MESSPR(MES,IP,IQ) -- 2000 FORMAT(1X,80A1) -- IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,2000)(AA(J),J=1,N) -- IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,2000)(AA(J),J=1,N) -- RETURN -- END --c --c --c --c --c -- SUBROUTINE MESSPR(MES,IP,IQ) -- save -- CHARACTER *1 MES(1),AST -- DATA AST/'*'/ --C --C DETERMINE THE LENGTH OF THE MESSAGE --C -- I1=0 -- DO 1400 I=1,10000 -- IF(MES(I).EQ.AST) GOTO 1600 -- I1=I -- 1400 CONTINUE -- 1600 CONTINUE -- IF ( (I1.NE.0) .AND. (IP.NE.0) ) -- 1 WRITE(IP,1800) (MES(I),I=1,I1) -- IF ( (I1.NE.0) .AND. (IQ.NE.0) ) -- 1 WRITE(IQ,1800) (MES(I),I=1,I1) -- 1800 FORMAT(1X,80A1) -- RETURN -- END -diff --git a/scipy/linalg/tests/test_interpolative.py b/scipy/linalg/tests/test_interpolative.py -index ddc56f7c7..95b83dfad 100644 ---- a/scipy/linalg/tests/test_interpolative.py -+++ b/scipy/linalg/tests/test_interpolative.py -@@ -1,4 +1,4 @@ --#****************************************************************************** -+# ****************************************************************************** - # Copyright (C) 2013 Kenneth L. Ho - # Redistribution and use in source and binary forms, with or without - # modification, are permitted provided that the following conditions are met: -@@ -24,7 +24,7 @@ - # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - # POSSIBILITY OF SUCH DAMAGE. --#****************************************************************************** -+# ****************************************************************************** - - import scipy.linalg.interpolative as pymatrixid - import numpy as np -@@ -36,8 +36,6 @@ from numpy.testing import (assert_, assert_allclose, assert_equal, - assert_array_equal) - import pytest - from pytest import raises as assert_raises --import sys --_IS_32BIT = (sys.maxsize < 2**32) - - - @pytest.fixture() -@@ -45,6 +43,12 @@ def eps(): - yield 1e-12 - - -+@pytest.fixture() -+def rng(): -+ rng = np.random.default_rng(1718313768084012) -+ yield rng -+ -+ - @pytest.fixture(params=[np.float64, np.complex128]) - def A(request): - # construct Hilbert matrix -@@ -73,36 +77,32 @@ class TestInterpolativeDecomposition: - @pytest.mark.parametrize( - "rand,lin_op", - [(False, False), (True, False), (True, True)]) -- def test_real_id_fixed_precision(self, A, L, eps, rand, lin_op): -- if _IS_32BIT and A.dtype == np.complex128 and rand: -- pytest.xfail("bug in external fortran code") -+ def test_real_id_fixed_precision(self, A, L, eps, rand, lin_op, rng): - # Test ID routines on a Hilbert matrix. - A_or_L = A if not lin_op else L - -- k, idx, proj = pymatrixid.interp_decomp(A_or_L, eps, rand=rand) -+ k, idx, proj = pymatrixid.interp_decomp(A_or_L, eps, rand=rand, rng=rng) - B = pymatrixid.reconstruct_matrix_from_id(A[:, idx[:k]], idx, proj) - assert_allclose(A, B, rtol=eps, atol=1e-08) - - @pytest.mark.parametrize( - "rand,lin_op", - [(False, False), (True, False), (True, True)]) -- def test_real_id_fixed_rank(self, A, L, eps, rank, rand, lin_op): -- if _IS_32BIT and A.dtype == np.complex128 and rand: -- pytest.xfail("bug in external fortran code") -+ def test_real_id_fixed_rank(self, A, L, eps, rank, rand, lin_op, rng): - k = rank - A_or_L = A if not lin_op else L - -- idx, proj = pymatrixid.interp_decomp(A_or_L, k, rand=rand) -+ idx, proj = pymatrixid.interp_decomp(A_or_L, k, rand=rand, rng=rng) - B = pymatrixid.reconstruct_matrix_from_id(A[:, idx[:k]], idx, proj) - assert_allclose(A, B, rtol=eps, atol=1e-08) - - @pytest.mark.parametrize("rand,lin_op", [(False, False)]) - def test_real_id_skel_and_interp_matrices( -- self, A, L, eps, rank, rand, lin_op): -+ self, A, L, eps, rank, rand, lin_op, rng): - k = rank - A_or_L = A if not lin_op else L - -- idx, proj = pymatrixid.interp_decomp(A_or_L, k, rand=rand) -+ idx, proj = pymatrixid.interp_decomp(A_or_L, k, rand=rand, rng=rng) - P = pymatrixid.reconstruct_interp_matrix(idx, proj) - B = pymatrixid.reconstruct_skel_matrix(A, k, idx) - assert_allclose(B, A[:, idx[:k]], rtol=eps, atol=1e-08) -@@ -111,25 +111,21 @@ class TestInterpolativeDecomposition: - @pytest.mark.parametrize( - "rand,lin_op", - [(False, False), (True, False), (True, True)]) -- def test_svd_fixed_precison(self, A, L, eps, rand, lin_op): -- if _IS_32BIT and A.dtype == np.complex128 and rand: -- pytest.xfail("bug in external fortran code") -+ def test_svd_fixed_precision(self, A, L, eps, rand, lin_op, rng): - A_or_L = A if not lin_op else L - -- U, S, V = pymatrixid.svd(A_or_L, eps, rand=rand) -+ U, S, V = pymatrixid.svd(A_or_L, eps, rand=rand, rng=rng) - B = U * S @ V.T.conj() - assert_allclose(A, B, rtol=eps, atol=1e-08) - - @pytest.mark.parametrize( - "rand,lin_op", - [(False, False), (True, False), (True, True)]) -- def test_svd_fixed_rank(self, A, L, eps, rank, rand, lin_op): -- if _IS_32BIT and A.dtype == np.complex128 and rand: -- pytest.xfail("bug in external fortran code") -+ def test_svd_fixed_rank(self, A, L, eps, rank, rand, lin_op, rng): - k = rank - A_or_L = A if not lin_op else L - -- U, S, V = pymatrixid.svd(A_or_L, k, rand=rand) -+ U, S, V = pymatrixid.svd(A_or_L, k, rand=rand, rng=rng) - B = U * S @ V.T.conj() - assert_allclose(A, B, rtol=eps, atol=1e-08) - -@@ -141,59 +137,39 @@ class TestInterpolativeDecomposition: - B = U * S @ V.T.conj() - assert_allclose(A, B, rtol=eps, atol=1e-08) - -- def test_estimate_spectral_norm(self, A): -+ def test_estimate_spectral_norm(self, A, rng): - s = svdvals(A) -- norm_2_est = pymatrixid.estimate_spectral_norm(A) -+ norm_2_est = pymatrixid.estimate_spectral_norm(A, rng=rng) - assert_allclose(norm_2_est, s[0], rtol=1e-6, atol=1e-8) - -- def test_estimate_spectral_norm_diff(self, A): -+ def test_estimate_spectral_norm_diff(self, A, rng): - B = A.copy() - B[:, 0] *= 1.2 - s = svdvals(A - B) -- norm_2_est = pymatrixid.estimate_spectral_norm_diff(A, B) -+ norm_2_est = pymatrixid.estimate_spectral_norm_diff(A, B, rng=rng) - assert_allclose(norm_2_est, s[0], rtol=1e-6, atol=1e-8) - -- def test_rank_estimates_array(self, A): -+ def test_rank_estimates_array(self, A, rng): - B = np.array([[1, 1, 0], [0, 0, 1], [0, 0, 1]], dtype=A.dtype) - - for M in [A, B]: - rank_tol = 1e-9 - rank_np = np.linalg.matrix_rank(M, norm(M, 2) * rank_tol) -- rank_est = pymatrixid.estimate_rank(M, rank_tol) -+ rank_est = pymatrixid.estimate_rank(M, rank_tol, rng=rng) - assert_(rank_est >= rank_np) - assert_(rank_est <= rank_np + 10) - -- def test_rank_estimates_lin_op(self, A): -+ def test_rank_estimates_lin_op(self, A, rng): - B = np.array([[1, 1, 0], [0, 0, 1], [0, 0, 1]], dtype=A.dtype) - - for M in [A, B]: - ML = aslinearoperator(M) - rank_tol = 1e-9 - rank_np = np.linalg.matrix_rank(M, norm(M, 2) * rank_tol) -- rank_est = pymatrixid.estimate_rank(ML, rank_tol) -+ rank_est = pymatrixid.estimate_rank(ML, rank_tol, rng=rng) - assert_(rank_est >= rank_np - 4) - assert_(rank_est <= rank_np + 4) - -- def test_rand(self): -- pymatrixid.seed('default') -- assert_allclose(pymatrixid.rand(2), [0.8932059, 0.64500803], -- rtol=1e-4, atol=1e-8) -- -- pymatrixid.seed(1234) -- x1 = pymatrixid.rand(2) -- assert_allclose(x1, [0.7513823, 0.06861718], rtol=1e-4, atol=1e-8) -- -- np.random.seed(1234) -- pymatrixid.seed() -- x2 = pymatrixid.rand(2) -- -- np.random.seed(1234) -- pymatrixid.seed(np.random.rand(55)) -- x3 = pymatrixid.rand(2) -- -- assert_allclose(x1, x2) -- assert_allclose(x1, x3) -- - def test_badcall(self): - A = hilbert(5).astype(np.float32) - with assert_raises(ValueError): -@@ -228,8 +204,6 @@ class TestInterpolativeDecomposition: - @pytest.mark.parametrize("rand", [True, False]) - @pytest.mark.parametrize("eps", [1, 0.1]) - def test_bug_9793(self, dtype, rand, eps): -- if _IS_32BIT and dtype == np.complex128 and rand: -- pytest.xfail("bug in external fortran code") - A = np.array([[-1, -1, -1, 0, 0, 0], - [0, 0, 0, 1, 1, 1], - [1, 0, 0, 1, 0, 0], --- -2.39.3 (Apple Git-146) - diff --git a/packages/scipy/patches/0009-Make-sreorth-recursive.patch b/packages/scipy/patches/0007-Make-sreorth-recursive.patch similarity index 98% rename from packages/scipy/patches/0009-Make-sreorth-recursive.patch rename to packages/scipy/patches/0007-Make-sreorth-recursive.patch index 0ca5929f..ee7654c0 100644 --- a/packages/scipy/patches/0009-Make-sreorth-recursive.patch +++ b/packages/scipy/patches/0007-Make-sreorth-recursive.patch @@ -1,7 +1,7 @@ From e4d1a570fa8bd4c710e10400822f60232e6408eb Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Sat, 6 Jul 2024 22:33:51 +0200 -Subject: [PATCH 9/18] Make sreorth recursive +Subject: [PATCH 7/14] Make sreorth recursive --- complex16/zreorth.F | 6 +++--- diff --git a/packages/scipy/patches/0008-Link-openblas-with-modules-that-require-f2c.patch b/packages/scipy/patches/0008-Link-openblas-with-modules-that-require-f2c.patch new file mode 100644 index 00000000..ca85ac04 --- /dev/null +++ b/packages/scipy/patches/0008-Link-openblas-with-modules-that-require-f2c.patch @@ -0,0 +1,31 @@ +From ccbb0fa0884d567c6139eeed7dc2dc9f8db4db3a Mon Sep 17 00:00:00 2001 +From: ryanking13 +Date: Sun, 28 Jul 2024 18:15:17 +0900 +Subject: [PATCH 8/14] Link openblas with modules that require f2c + +DOP requires symbols from f2c, which is provided by +OpenBLAS. +This patch adds OpenBLAS as a dependency to it. + +Co-Developed-by: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> +--- + scipy/integrate/meson.build | 2 +- + scipy/optimize/meson.build | 6 +++--- + scipy/stats/meson.build | 2 +- + 3 files changed, 5 insertions(+), 5 deletions(-) + +diff --git a/scipy/integrate/meson.build b/scipy/integrate/meson.build +index 23a715dd58..e5cd9ad4c8 100644 +--- a/scipy/integrate/meson.build ++++ b/scipy/integrate/meson.build +@@ -154,7 +154,7 @@ py3.extension_module('_dop', + f2py_gen.process('dop.pyf'), + link_with: [dop_lib], + c_args: [Wno_unused_variable], +- dependencies: [fortranobject_dep], ++ dependencies: [lapack, fortranobject_dep], + link_args: version_link_args, + install: true, + link_language: 'fortran', +-- +2.39.3 (Apple Git-146) diff --git a/packages/scipy/patches/0008-Mark-mvndst-functions-recursive.patch b/packages/scipy/patches/0008-Mark-mvndst-functions-recursive.patch deleted file mode 100644 index 705d648d..00000000 --- a/packages/scipy/patches/0008-Mark-mvndst-functions-recursive.patch +++ /dev/null @@ -1,38 +0,0 @@ -From c11745d763407d9a2bb195a21e2a8afaf7635248 Mon Sep 17 00:00:00 2001 -From: Hood Chatham -Date: Sat, 6 Jul 2024 22:38:55 +0200 -Subject: [PATCH 8/18] Mark mvndst functions recursive - ---- - scipy/stats/mvndst.f | 8 ++++---- - 1 file changed, 4 insertions(+), 4 deletions(-) - -diff --git a/scipy/stats/mvndst.f b/scipy/stats/mvndst.f -index 41afa7e74..5065a15ff 100644 ---- a/scipy/stats/mvndst.f -+++ b/scipy/stats/mvndst.f -@@ -21,8 +21,8 @@ - * Pullman, WA 99164-3113 - * Email : alangenz@wsu.edu - * -- SUBROUTINE mvnun(d, n, lower, upper, means, covar, maxpts, -- & abseps, releps, value, inform) -+ RECURSIVE SUBROUTINE mvnun(d, n, lower, upper, means, covar, -+ & maxpts, abseps, releps, value, inform) - * Parameters - * - * d integer, dimensionality of the data -@@ -88,8 +88,8 @@ - END - - -- SUBROUTINE mvnun_weighted(d, n, lower, upper, means, weights, -- & covar, maxpts, abseps, releps, -+ recursive SUBROUTINE mvnun_weighted(d, n, lower, upper, means, -+ & weights, covar, maxpts, abseps, releps, - & value, inform) - * Parameters - * --- -2.34.1 - diff --git a/packages/scipy/patches/0012-Remove-chla_transtype.patch b/packages/scipy/patches/0009-Remove-chla_transtype.patch similarity index 90% rename from packages/scipy/patches/0012-Remove-chla_transtype.patch rename to packages/scipy/patches/0009-Remove-chla_transtype.patch index c4afc190..a5bcd2d8 100644 --- a/packages/scipy/patches/0012-Remove-chla_transtype.patch +++ b/packages/scipy/patches/0009-Remove-chla_transtype.patch @@ -1,27 +1,29 @@ -From 848c94e218e89d866978fbc883cbb2d919f56ce9 Mon Sep 17 00:00:00 2001 -From: Hood Chatham -Date: Wed, 31 Jul 2024 10:29:47 +0200 -Subject: [PATCH 12/18] Remove chla_transtype - -The signature should probably be `int chla_transtype(char* res, int *trans)`. -This just deletes it entirely due to laziness. - ---- - scipy/linalg/cython_lapack_signatures.txt | 1 - - 1 file changed, 1 deletion(-) - -diff --git a/scipy/linalg/cython_lapack_signatures.txt b/scipy/linalg/cython_lapack_signatures.txt -index 1f3dc226ab..28aa8b8c22 100644 ---- a/scipy/linalg/cython_lapack_signatures.txt -+++ b/scipy/linalg/cython_lapack_signatures.txt -@@ -108,7 +108,6 @@ void chetrs(char *uplo, int *n, int *nrhs, c *a, int *lda, int *ipiv, c *b, int - void chetrs2(char *uplo, int *n, int *nrhs, c *a, int *lda, int *ipiv, c *b, int *ldb, c *work, int *info) - void chfrk(char *transr, char *uplo, char *trans, int *n, int *k, s *alpha, c *a, int *lda, s *beta, c *c) - void chgeqz(char *job, char *compq, char *compz, int *n, int *ilo, int *ihi, c *h, int *ldh, c *t, int *ldt, c *alpha, c *beta, c *q, int *ldq, c *z, int *ldz, c *work, int *lwork, s *rwork, int *info) --char chla_transtype(int *trans) - void chpcon(char *uplo, int *n, c *ap, int *ipiv, s *anorm, s *rcond, c *work, int *info) - void chpev(char *jobz, char *uplo, int *n, c *ap, s *w, c *z, int *ldz, c *work, s *rwork, int *info) - void chpevd(char *jobz, char *uplo, int *n, c *ap, s *w, c *z, int *ldz, c *work, int *lwork, s *rwork, int *lrwork, int *iwork, int *liwork, int *info) --- -2.39.3 (Apple Git-146) - +From 848c94e218e89d866978fbc883cbb2d919f56ce9 Mon Sep 17 00:00:00 2001 +From: Hood Chatham +Date: Wed, 31 Jul 2024 10:29:47 +0200 +Subject: [PATCH 9/14] Remove chla_transtype + +The signature should probably be `int chla_transtype(char* res, int *trans)`. +This just deletes it entirely due to laziness. + +Note: this patch file has LF line endings, similar to the file it patches. + +--- + scipy/linalg/cython_lapack_signatures.txt | 1 - + 1 file changed, 1 deletion(-) + +diff --git a/scipy/linalg/cython_lapack_signatures.txt b/scipy/linalg/cython_lapack_signatures.txt +index 5aa59d96e..afdc9480f 100644 +--- a/scipy/linalg/cython_lapack_signatures.txt ++++ b/scipy/linalg/cython_lapack_signatures.txt +@@ -108,7 +108,6 @@ void chetrs(char *uplo, int *n, int *nrhs, c *a, int *lda, int *ipiv, c *b, int + void chetrs2(char *uplo, int *n, int *nrhs, c *a, int *lda, int *ipiv, c *b, int *ldb, c *work, int *info) + void chfrk(char *transr, char *uplo, char *trans, int *n, int *k, s *alpha, c *a, int *lda, s *beta, c *c) + void chgeqz(char *job, char *compq, char *compz, int *n, int *ilo, int *ihi, c *h, int *ldh, c *t, int *ldt, c *alpha, c *beta, c *q, int *ldq, c *z, int *ldz, c *work, int *lwork, s *rwork, int *info) +-char chla_transtype(int *trans) + void chpcon(char *uplo, int *n, c *ap, int *ipiv, s *anorm, s *rcond, c *work, int *info) + void chpev(char *jobz, char *uplo, int *n, c *ap, s *w, c *z, int *ldz, c *work, s *rwork, int *info) + void chpevd(char *jobz, char *uplo, int *n, c *ap, s *w, c *z, int *ldz, c *work, int *lwork, s *rwork, int *lrwork, int *iwork, int *liwork, int *info) +-- +2.39.3 (Apple Git-146) + diff --git a/packages/scipy/patches/0010-Link-openblas-with-modules-that-require-f2c.patch b/packages/scipy/patches/0010-Link-openblas-with-modules-that-require-f2c.patch deleted file mode 100644 index ad975ccd..00000000 --- a/packages/scipy/patches/0010-Link-openblas-with-modules-that-require-f2c.patch +++ /dev/null @@ -1,76 +0,0 @@ -From ccbb0fa0884d567c6139eeed7dc2dc9f8db4db3a Mon Sep 17 00:00:00 2001 -From: ryanking13 -Date: Sun, 28 Jul 2024 18:15:17 +0900 -Subject: [PATCH 10/18] Link openblas with modules that require f2c - -Some fortran modules require symbols from f2c, which is provided by -openblas. -This patch adds openblas as a dependency to the modules that require f2c -symbols. - -Co-Developed-by: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> ---- - scipy/integrate/meson.build | 2 +- - scipy/optimize/meson.build | 6 +++--- - scipy/stats/meson.build | 2 +- - 3 files changed, 5 insertions(+), 5 deletions(-) - -diff --git a/scipy/integrate/meson.build b/scipy/integrate/meson.build -index 23a715dd58..e5cd9ad4c8 100644 ---- a/scipy/integrate/meson.build -+++ b/scipy/integrate/meson.build -@@ -154,7 +154,7 @@ py3.extension_module('_dop', - f2py_gen.process('dop.pyf'), - link_with: [dop_lib], - c_args: [Wno_unused_variable], -- dependencies: [fortranobject_dep], -+ dependencies: [lapack, fortranobject_dep], - link_args: version_link_args, - install: true, - link_language: 'fortran', -diff --git a/scipy/optimize/meson.build b/scipy/optimize/meson.build -index d6c20d3d53..d7f0284b5b 100644 ---- a/scipy/optimize/meson.build -+++ b/scipy/optimize/meson.build -@@ -125,7 +125,7 @@ py3.extension_module('_cobyla', - c_args: [Wno_unused_variable], - fortran_args: fortran_ignore_warnings, - link_args: version_link_args, -- dependencies: [fortranobject_dep], -+ dependencies: [lapack, fortranobject_dep], - install: true, - link_language: 'fortran', - subdir: 'scipy/optimize' -@@ -135,7 +135,7 @@ py3.extension_module('_minpack2', - [f2py_gen.process('minpack2/minpack2.pyf'), 'minpack2/dcsrch.f', 'minpack2/dcstep.f'], - fortran_args: fortran_ignore_warnings, - link_args: version_link_args, -- dependencies: [fortranobject_dep], -+ dependencies: [lapack, fortranobject_dep], - override_options: ['b_lto=false'], - install: true, - link_language: 'fortran', -@@ -146,7 +146,7 @@ py3.extension_module('_slsqp', - [f2py_gen.process('slsqp/slsqp.pyf'), 'slsqp/slsqp_optmz.f'], - fortran_args: fortran_ignore_warnings, - link_args: version_link_args, -- dependencies: [fortranobject_dep], -+ dependencies: [lapack, fortranobject_dep], - install: true, - link_language: 'fortran', - subdir: 'scipy/optimize' -diff --git a/scipy/stats/meson.build b/scipy/stats/meson.build -index bb43e3b2e9..358279a93b 100644 ---- a/scipy/stats/meson.build -+++ b/scipy/stats/meson.build -@@ -36,7 +36,7 @@ py3.extension_module('_mvn', - # Wno-surprising is to suppress a pointless warning with GCC 10-12 - # (see GCC bug 98411: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98411) - fortran_args: [fortran_ignore_warnings, _fflag_Wno_surprising], -- dependencies: [fortranobject_dep], -+ dependencies: [lapack, fortranobject_dep], - link_args: version_link_args, - install: true, - link_language: 'fortran', --- -2.39.3 (Apple Git-146) diff --git a/packages/scipy/patches/0013-Set-wrapper-return-type-to-int.patch b/packages/scipy/patches/0010-Set-wrapper-return-type-to-int.patch similarity index 94% rename from packages/scipy/patches/0013-Set-wrapper-return-type-to-int.patch rename to packages/scipy/patches/0010-Set-wrapper-return-type-to-int.patch index c20be03f..2f6bc50b 100644 --- a/packages/scipy/patches/0013-Set-wrapper-return-type-to-int.patch +++ b/packages/scipy/patches/0010-Set-wrapper-return-type-to-int.patch @@ -1,7 +1,7 @@ From b5d05197de084ab3cab52241f163bae7519b6027 Mon Sep 17 00:00:00 2001 From: Hood Chatham Date: Wed, 31 Jul 2024 11:48:12 +0200 -Subject: [PATCH 13/18] Set wrapper return type to int +Subject: [PATCH 10/14] Set wrapper return type to int --- scipy/linalg/_generate_pyx.py | 2 +- diff --git a/packages/scipy/patches/0011-Remove-fpchec-inline-if-then-endif-constructs.patch b/packages/scipy/patches/0011-Remove-fpchec-inline-if-then-endif-constructs.patch deleted file mode 100644 index 78272f58..00000000 --- a/packages/scipy/patches/0011-Remove-fpchec-inline-if-then-endif-constructs.patch +++ /dev/null @@ -1,94 +0,0 @@ -From b43a231f8326d6953929030131c3fb6b2cb163bd Mon Sep 17 00:00:00 2001 -From: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> -Date: Wed, 15 May 2024 21:29:02 +0530 -Subject: [PATCH 11/18] Remove fpchec inline if-then-endif constructs - -This PR removes the single-line if-then-endif constructs in fpchec.f -that were causing syntactical errors when compiling with f2c, possibly -because fpchec uses some dated, punch-card FORTRAN syntax. It converts -them to statements split over multiple lines. - -This patch has been upstreamed via https://github.com/scipy/scipy/pull/21365 -and it can be safely removed once SciPy v1.15.0 is released and is being -integrated in Pyodide. - ---- - scipy/interpolate/fitpack/fpchec.f | 42 +++++++++++++++++++++++------- - 1 file changed, 32 insertions(+), 10 deletions(-) - -diff --git a/scipy/interpolate/fitpack/fpchec.f b/scipy/interpolate/fitpack/fpchec.f -index 75a58c40ec..215f38f31f 100644 ---- a/scipy/interpolate/fitpack/fpchec.f -+++ b/scipy/interpolate/fitpack/fpchec.f -@@ -29,36 +29,58 @@ c .. - nk2 = nk1+1 - ier = 10 - c check condition no 1 -- if(nk1.lt.k1 .or. nk1.gt.m)then; ier=10; go to 80; endif -+ if (nk1.lt.k1 .or. nk1.gt.m) then -+ ier = 10 -+ go to 80 -+ endif - c check condition no 2 - j = n - do 20 i=1,k -- if(t(i).gt.t(i+1))then; ier=20; go to 80; endif -- if(t(j).lt.t(j-1))then; ier=20; go to 80; endif -+ if (t(i) .gt. t(i+1)) then -+ ier = 20 -+ go to 80 -+ endif -+ if (t(j) .lt. t(j-1)) then -+ ier = 20 -+ go to 80 -+ endif - j = j-1 - 20 continue - c check condition no 3 - do 30 i=k2,nk2 -- if(t(i).le.t(i-1))then; ier=30; go to 80; endif -+ if (t(i) .le. t(i-1)) then -+ ier = 30 -+ go to 80 -+ endif - 30 continue - c check condition no 4 -- if(x(1).lt.t(k1) .or. x(m).gt.t(nk2))then; ier=40; go to 80; -+ if (x(1).lt.t(k1) .or. x(m).gt.t(nk2)) then -+ ier = 40 -+ go to 80 - endif - c check condition no 5 -- if(x(1).ge.t(k2) .or. x(m).le.t(nk1))then; ier=50; go to 80; -+ if (x(1).ge.t(k2) .or. x(m).le.t(nk1)) then -+ ier = 50 -+ go to 80 - endif - i = 1 - l = k2 - nk3 = nk1-1 -- if(nk3.lt.2) go to 70 -+ if (nk3 .lt. 2) go to 70 - do 60 j=2,nk3 - tj = t(j) - l = l+1 - tl = t(l) - 40 i = i+1 -- if(i.ge.m)then; ier=50; go to 80; endif -- if(x(i).le.tj) go to 40 -- if(x(i).ge.tl)then; ier=50; go to 80; endif -+ if (i .ge. m) then -+ ier = 50 -+ go to 80 -+ endif -+ if (x(i) .le. tj) go to 40 -+ if (x(i) .ge. tl) then -+ ier = 50 -+ go to 80 -+ endif - 60 continue - 70 ier = 0 - 80 return --- -2.39.3 (Apple Git-146) - diff --git a/packages/scipy/patches/0017-Remove-test-modules-that-fail-to-build.patch b/packages/scipy/patches/0011-Remove-test-modules-that-fail-to-build.patch similarity index 59% rename from packages/scipy/patches/0017-Remove-test-modules-that-fail-to-build.patch rename to packages/scipy/patches/0011-Remove-test-modules-that-fail-to-build.patch index 56be63ec..30349453 100644 --- a/packages/scipy/patches/0017-Remove-test-modules-that-fail-to-build.patch +++ b/packages/scipy/patches/0011-Remove-test-modules-that-fail-to-build.patch @@ -1,32 +1,26 @@ From e21f33695da3275ec81b5f94685f0e4ac92c9ad5 Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Mon, 30 Oct 2023 14:35:04 +0000 -Subject: [PATCH 17/18] Remove test modules that fail to build +Subject: [PATCH 11/14] Remove test modules that fail to build These are tests and they have both void vs int return value problems and implicit function argument cast problems. Not worth fixing for tests. --- - scipy/integrate/meson.build | 18 ------------------ - scipy/io/meson.build | 21 --------------------- - 2 files changed, 39 deletions(-) + scipy/integrate/meson.build | 12 ------------ + scipy/io/meson.build | 15 --------------- + 2 files changed, 27 deletions(-) diff --git a/scipy/integrate/meson.build b/scipy/integrate/meson.build -index ae9e2466e1..e11626db0d 100644 +index db6a5414aa..30f738a077 100644 --- a/scipy/integrate/meson.build +++ b/scipy/integrate/meson.build -@@ -187,24 +187,6 @@ py3.extension_module('_test_multivariate', +@@ -120,18 +120,6 @@ py3.extension_module('_test_multivariate', install_tag: 'tests' ) --_test_odeint_banded_module = custom_target('_test_odeint_banded_module', -- output: ['_test_odeint_bandedmodule.c', '_test_odeint_banded-f2pywrappers.f'], -- input: 'tests/test_odeint_banded.pyf', -- command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] --) -- -py3.extension_module('_test_odeint_banded', -- ['tests/banded5x5.f', _test_odeint_banded_module], +- ['tests/banded5x5.f', f2py_gen.process('tests/test_odeint_banded.pyf')], - link_with: [lsoda_lib, mach_lib], - fortran_args: _fflag_Wno_unused_dummy_argument, - link_args: version_link_args, @@ -38,22 +32,16 @@ index ae9e2466e1..e11626db0d 100644 -) - subdir('_ivp') + subdir('_rules') subdir('tests') - diff --git a/scipy/io/meson.build b/scipy/io/meson.build -index d6fc6dc749..af04022208 100644 +index 60f71c6968..af04022208 100644 --- a/scipy/io/meson.build +++ b/scipy/io/meson.build -@@ -1,24 +1,3 @@ --_test_fortran_module = custom_target('_test_fortran_module', -- output: ['_test_fortranmodule.c'], -- input: 'test_fortran.pyf', -- command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] --) -- +@@ -1,18 +1,3 @@ -py3.extension_module('_test_fortran', - [ -- _test_fortran_module, +- f2py_gen.process('test_fortran.pyf'), - '_test_fortran.f' - ], - c_args: [Wno_unused_variable], @@ -70,5 +58,5 @@ index d6fc6dc749..af04022208 100644 '__init__.py', '_fortran.py', -- -2.39.3 (Apple Git-146) +2.39.5 (Apple Git-154) diff --git a/packages/scipy/patches/0018-Fix-lapack-larfg-function-signature.patch b/packages/scipy/patches/0012-Fix-lapack-larfg-function-signature.patch similarity index 82% rename from packages/scipy/patches/0018-Fix-lapack-larfg-function-signature.patch rename to packages/scipy/patches/0012-Fix-lapack-larfg-function-signature.patch index e2ffa67b..5380f151 100644 --- a/packages/scipy/patches/0018-Fix-lapack-larfg-function-signature.patch +++ b/packages/scipy/patches/0012-Fix-lapack-larfg-function-signature.patch @@ -1,7 +1,7 @@ From 8b06e7fef50327f84140cb09a3d9237e18b38a35 Mon Sep 17 00:00:00 2001 From: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> Date: Thu, 5 Sep 2024 21:14:20 +0530 -Subject: [PATCH 18/18] Fix lapack larfg function signature +Subject: [PATCH 12/14] Fix lapack larfg function signature This patch fixes the signature of the LAPACK routine larfg. Please see https://github.com/pyodide/pyodide/issues/3379 for more details. @@ -14,12 +14,12 @@ Suggested-by: Hood Chatham 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/scipy/linalg/flapack_other.pyf.src b/scipy/linalg/flapack_other.pyf.src -index 99d4886558..bf7256e605 100644 +index 1db51bbd83..c8ac1e94fe 100644 --- a/scipy/linalg/flapack_other.pyf.src +++ b/scipy/linalg/flapack_other.pyf.src -@@ -2310,13 +2310,12 @@ function lange(norm,m,n,a,lda,work) result(n2) - dimension(m+1),intent(cache,hide) :: work - end function lange +@@ -2214,13 +2214,12 @@ function lantr(norm, uplo, diag, m, n, a, lda, work) result(n2) + + end function lantr -subroutine larfg(n, alpha, x, incx, tau, lx) +subroutine larfg(n, alpha, x, incx, tau) @@ -34,5 +34,5 @@ index 99d4886558..bf7256e605 100644 subroutine larf(side,m,n,v,incv,tau,c,ldc,work,lwork) -- -2.39.3 (Apple Git-146) +2.39.5 (Apple Git-154) diff --git a/packages/scipy/patches/0013-ENH-MAINT-sparse.linalg-rewrite-ARPACK-in-C-22748.patch b/packages/scipy/patches/0013-ENH-MAINT-sparse.linalg-rewrite-ARPACK-in-C-22748.patch new file mode 100644 index 00000000..01958992 --- /dev/null +++ b/packages/scipy/patches/0013-ENH-MAINT-sparse.linalg-rewrite-ARPACK-in-C-22748.patch @@ -0,0 +1,51097 @@ +From e26e64d1910d725089bddd9f7e4fbbc7e616ed02 Mon Sep 17 00:00:00 2001 +From: Ilhan Polat +Date: Wed, 25 Jun 2025 22:50:58 +0200 +Subject: [PATCH 13/14] ENH:MAINT: sparse.linalg: rewrite ARPACK in C (#22748) + +This patch is from the recently merged PR https://github.com/scipy/scipy/pull/22748. +We backport it into the 1.16.x branch as the PR was not too far ahead of the branch. + +* MAINT:sparse.linalg: Remove ARPACK F77 code + +* ENH:sparse:linalg: Add ARPACK header file + +* ENH:sparse.linalg: Add ARPACK C code for nonsym complex + +* MAINT:sparse.linalg: Add MSVC guards for complex definitions + +SQ: remove complexdefs.h + +* ENH:sparse.linalg: Add ARPACK C code for nonsym real + +* MAINT:sparse.linalg: Adjust meson file for ARPACK C rewrite + +* ENH:sparse.linalg: Add ARPACK C code for sym real + +* MAINT:sparse.linalg: Adjust arpack.py for C rewrite + +[skip ci] + +* MAINT: sparse.linalg: Add undefs for custom macros to header + +* MAINT: sparse.linalg: Rename the ishift field to shift in nonsym + +* MAINT: sparse.linalg: Fix the LAPACK call syntax in sym code + +* MAINT: sparse.linalg: Finish ARPACK full compiled meson file + +[skip ci] + +* MAINT: sparse.linalg: Finish ARPACK full compiled header file + +* MAINT: sparse.linalg: Finish ARPACK full compiled nonsym complex solvers + +* MAINT: sparse.linalg: Finish ARPACK full compiled nonsymmetric real solver + +* MAINT: sparse.linalg: Finish ARPACK full compiled sym real solvers + +* MAINT: sparse.linalg: Modify ARPACK Python driver file + +[skip ci] + +* MAINT: sparse.linalg: Add new module file for ARPACK interface + +* MAINT: sparse.linalg: Clean up gitignore file for removed F77 code + +[skip ci] + +* MAINT: sparse.linalg: Remove the ARPACK int selection + +* MAINT: sparse.linalg: Adjustments to the arpack.py file after rewrite + +* MAINT: sparse.linalg: Add nonsymmetric symbols to the header file + +* MAINT: sparse.linalg: ARPACK nonsym real fixes and typos + +* MAINT: sparse.linalg: Remove dependence to complex dotc routines in ARPACK + +* MAINT: sparse.linalg: Create the ARPACK extension module code + +* MAINT: sparse.linalg: Adjust meson file for ARPACK ext module + +[skip ci] + +* MAINT: sparse.linalg: Adjustments to the arpack.py file for rng + +* MAINT: sparse.linalg: Temporary changes to module for testing + +* MAINT: sparse.linalg: Add ido=5 for random OPX ARPACK operation + +* MAINT: sparse.linalg: Fix comments in nonsymmetric complex code + +* MAINT: sparse.linalg: Printed version of nonsym real code for segfault fixes + +[skip ci] + +* MAINT:sparse.linalg: Add more debugging to nonsym ARPACK code + +* ENH:sparse.linalg: Add sneupd to the ARPACK module + +[skip ci] + +* MAINT:sparse.linalg: More troubleshooting segfaults + +[skip ci] + +* MAINT: sparse.linalg: Segfaults fixed in ARPACK nonsym real solver + +[skip ci] + +* MAINT:sparse.linalg: Fixes various nonsym real bugs verified large examples + +[skip ci] + +* FIX:sparse.linalg: Typo in the post-processing nonsym real eigs + +[skip ci] + +* ENH:sparse.linalg: Complex nonsym solver first pass + +[skip ci] + +* MAINT:sparse.linalg: Add zneupd to module and convert to multi-phase init + +[skip ci] + +* MAINT:sparse.linalg: Add missing casts for NumPy pointers in ARPACK module + +[skip ci] + +* FIX:sparse.linalg: Modify ARPACK codes for random array on Python side + +[skip ci] + +* ENH:sparse.linalg: Add nonsym complex protos to header file + +[skip ci] + +* ENH:sparse.linalg: Add nonsym complex ARPACK solvers + +[skip ci] + +* TMP:sparse.linalg: Turn on pedantic flag on ARPACK + +[skip ci] + +* SQ: Arpack.py + +* ENH:sparse.linalg: Complete the rewrite of ARPACK sym solvers + +[skip ci] + +* ENH:sparse.linalg: Complete all the function wrapping in ARPACK module + +[skip ci] + +* SQ: arpack.py + +* ENH:sparse.linalg: Expose all the functions in ARPAKC header + +* FIX:sparse.linalg: Allow for user defined initial vector in NonSym real ARPACK + +* TST:sparse.linalg: Allow for the reentrant ARPACK test + +[skip ci] + +* BUG:sparse.linalg: Fix the evec reordering in nonsym real ARPACK solver + +* BUG:sparse.linalg: Fix reordering in nonsym complex ARPACK solver + +* BUG:sparse.linalg: Clear error code after aupd calls in ARPACK + +* MAINT:sparse.linalg: Remove unused variables from nonsym real ARPACK code + +* MAINT:sparse.linalg: Remove unused variables from nonsym complex ARPACK code + +* MAINT:sparse.linalg: Remove hangups from sym ARPACK solver + +* MAINT:sparse.linalg: Remove compiler flags from ARPACK meson file + +[skip ci] + +* BUG:sparse.linalg: Fix a few bugs in ARPACK sym solvers + +* TST:sparse.linalg: Enable parallel and reentrance tests + +* TST:sparse.linalg: Parametrize ARPACK tests + +* MAINT:sparse.linalg: Remove Cpp guards from header + +* BUG:sparse.linalg: Correct double parsing in dseupd + +* TST:sparse.linalg: Remove unused import + +* MAINT:sparse.linalg: int guard ARPACK maxiter value + +* BUG:sparse.linalg: Fix typos in ARPACK nonsym complex solver + +* MAINT:sparse.linalg: Remove spurious entries from the ARPACK struct and rename symbols + +* MAINT:sparse.linalg: Remove spurious entries from the ARPACK dict + +* MAINT:sparse.linalg: Add ARPACK license, struct member info and rename symbols + +* MAINT:sparse.linalg: Rename exposed symbols with ARPACK prefix + +* MAINT:sparse.linalg: Rename exposed symbols with ARPACK prefix + +* MAINT:sparse.linalg: Rename exposed symbols with ARPACK prefix +--- + scipy/sparse/linalg/_eigen/_svds.py | 3 - + .../linalg/_eigen/arpack/ARPACK/CHANGES | 431 ---- + .../linalg/_eigen/arpack/ARPACK/COPYING | 45 - + .../linalg/_eigen/arpack/ARPACK/README.md | 376 --- + .../linalg/_eigen/arpack/ARPACK/README.scipy | 28 - + .../linalg/_eigen/arpack/ARPACK/SRC/ccdotc.f | 36 - + .../linalg/_eigen/arpack/ARPACK/SRC/cgetv0.f | 416 --- + .../linalg/_eigen/arpack/ARPACK/SRC/cnaitr.f | 850 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/cnapps.f | 507 ---- + .../linalg/_eigen/arpack/ARPACK/SRC/cnaup2.f | 801 ------ + .../linalg/_eigen/arpack/ARPACK/SRC/cnaupd.f | 664 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/cneigh.f | 257 -- + .../linalg/_eigen/arpack/ARPACK/SRC/cneupd.f | 876 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/cngets.f | 178 -- + .../linalg/_eigen/arpack/ARPACK/SRC/csortc.f | 322 --- + .../linalg/_eigen/arpack/ARPACK/SRC/cstatn.f | 51 - + .../linalg/_eigen/arpack/ARPACK/SRC/debug.h | 16 - + .../linalg/_eigen/arpack/ARPACK/SRC/dgetv0.f | 421 ---- + .../linalg/_eigen/arpack/ARPACK/SRC/dnaitr.f | 840 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/dnapps.f | 649 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/dnaup2.f | 846 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/dnaupd.f | 693 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/dnconv.f | 146 -- + .../linalg/_eigen/arpack/ARPACK/SRC/dneigh.f | 318 --- + .../linalg/_eigen/arpack/ARPACK/SRC/dneupd.f | 1071 -------- + .../linalg/_eigen/arpack/ARPACK/SRC/dngets.f | 231 -- + .../linalg/_eigen/arpack/ARPACK/SRC/dsaitr.f | 853 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/dsapps.f | 518 ---- + .../linalg/_eigen/arpack/ARPACK/SRC/dsaup2.f | 851 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/dsaupd.f | 690 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/dsconv.f | 138 - + .../linalg/_eigen/arpack/ARPACK/SRC/dseigt.f | 181 -- + .../linalg/_eigen/arpack/ARPACK/SRC/dsesrt.f | 217 -- + .../linalg/_eigen/arpack/ARPACK/SRC/dseupd.f | 867 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/dsgets.f | 219 -- + .../linalg/_eigen/arpack/ARPACK/SRC/dsortc.f | 344 --- + .../linalg/_eigen/arpack/ARPACK/SRC/dsortr.f | 218 -- + .../linalg/_eigen/arpack/ARPACK/SRC/dstatn.f | 61 - + .../linalg/_eigen/arpack/ARPACK/SRC/dstats.f | 47 - + .../linalg/_eigen/arpack/ARPACK/SRC/dstqrb.f | 594 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/sgetv0.f | 421 ---- + .../linalg/_eigen/arpack/ARPACK/SRC/snaitr.f | 840 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/snapps.f | 647 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/snaup2.f | 847 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/snaupd.f | 693 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/snconv.f | 146 -- + .../linalg/_eigen/arpack/ARPACK/SRC/sneigh.f | 318 --- + .../linalg/_eigen/arpack/ARPACK/SRC/sneupd.f | 1070 -------- + .../linalg/_eigen/arpack/ARPACK/SRC/sngets.f | 231 -- + .../linalg/_eigen/arpack/ARPACK/SRC/ssaitr.f | 853 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/ssapps.f | 516 ---- + .../linalg/_eigen/arpack/ARPACK/SRC/ssaup2.f | 850 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/ssaupd.f | 690 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/ssconv.f | 138 - + .../linalg/_eigen/arpack/ARPACK/SRC/sseigt.f | 181 -- + .../linalg/_eigen/arpack/ARPACK/SRC/ssesrt.f | 217 -- + .../linalg/_eigen/arpack/ARPACK/SRC/sseupd.f | 867 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/ssgets.f | 219 -- + .../linalg/_eigen/arpack/ARPACK/SRC/ssortc.f | 344 --- + .../linalg/_eigen/arpack/ARPACK/SRC/ssortr.f | 218 -- + .../linalg/_eigen/arpack/ARPACK/SRC/sstatn.f | 61 - + .../linalg/_eigen/arpack/ARPACK/SRC/sstats.f | 47 - + .../linalg/_eigen/arpack/ARPACK/SRC/sstqrb.f | 594 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/stat.h | 21 - + .../linalg/_eigen/arpack/ARPACK/SRC/version.h | 30 - + .../linalg/_eigen/arpack/ARPACK/SRC/zgetv0.f | 416 --- + .../linalg/_eigen/arpack/ARPACK/SRC/znaitr.f | 850 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/znapps.f | 507 ---- + .../linalg/_eigen/arpack/ARPACK/SRC/znaup2.f | 801 ------ + .../linalg/_eigen/arpack/ARPACK/SRC/znaupd.f | 664 ----- + .../linalg/_eigen/arpack/ARPACK/SRC/zneigh.f | 257 -- + .../linalg/_eigen/arpack/ARPACK/SRC/zneupd.f | 876 ------- + .../linalg/_eigen/arpack/ARPACK/SRC/zngets.f | 178 -- + .../linalg/_eigen/arpack/ARPACK/SRC/zsortc.f | 322 --- + .../linalg/_eigen/arpack/ARPACK/SRC/zstatn.f | 51 - + .../linalg/_eigen/arpack/ARPACK/SRC/zzdotc.f | 36 - + .../linalg/_eigen/arpack/ARPACK/UTIL/cmout.f | 250 -- + .../linalg/_eigen/arpack/ARPACK/UTIL/cvout.f | 240 -- + .../linalg/_eigen/arpack/ARPACK/UTIL/dmout.f | 167 -- + .../linalg/_eigen/arpack/ARPACK/UTIL/dvout.f | 122 - + .../linalg/_eigen/arpack/ARPACK/UTIL/icnteq.f | 18 - + .../linalg/_eigen/arpack/ARPACK/UTIL/icopy.f | 77 - + .../linalg/_eigen/arpack/ARPACK/UTIL/iset.f | 16 - + .../linalg/_eigen/arpack/ARPACK/UTIL/iswap.f | 55 - + .../linalg/_eigen/arpack/ARPACK/UTIL/ivout.f | 120 - + .../_eigen/arpack/ARPACK/UTIL/second_NONE.f | 36 - + .../linalg/_eigen/arpack/ARPACK/UTIL/smout.f | 157 -- + .../linalg/_eigen/arpack/ARPACK/UTIL/svout.f | 112 - + .../linalg/_eigen/arpack/ARPACK/UTIL/zmout.f | 250 -- + .../linalg/_eigen/arpack/ARPACK/UTIL/zvout.f | 240 -- + .../linalg/_eigen/arpack/ARPACK/_arpack.h | 266 ++ + .../_eigen/arpack/ARPACK/_arpack_n_double.c | 2101 ++++++++++++++++ + .../_eigen/arpack/ARPACK/_arpack_n_double.h | 32 + + .../arpack/ARPACK/_arpack_n_double_complex.c | 1861 ++++++++++++++ + .../arpack/ARPACK/_arpack_n_double_complex.h | 45 + + .../_eigen/arpack/ARPACK/_arpack_n_single.c | 2101 ++++++++++++++++ + .../_eigen/arpack/ARPACK/_arpack_n_single.h | 32 + + .../arpack/ARPACK/_arpack_n_single_complex.c | 1861 ++++++++++++++ + .../arpack/ARPACK/_arpack_n_single_complex.h | 45 + + .../_eigen/arpack/ARPACK/_arpack_s_double.c | 2238 +++++++++++++++++ + .../_eigen/arpack/ARPACK/_arpack_s_double.h | 31 + + .../_eigen/arpack/ARPACK/_arpack_s_single.c | 2238 +++++++++++++++++ + .../_eigen/arpack/ARPACK/_arpack_s_single.h | 31 + + scipy/sparse/linalg/_eigen/arpack/README | 91 - + .../linalg/_eigen/arpack/_arpackmodule.c | 1078 ++++++++ + scipy/sparse/linalg/_eigen/arpack/arpack.py | 382 +-- + .../linalg/_eigen/arpack/arpack.pyf.src | 213 -- + scipy/sparse/linalg/_eigen/arpack/meson.build | 122 +- + .../linalg/_eigen/arpack/tests/test_arpack.py | 169 +- + 109 files changed, 14278 insertions(+), 35406 deletions(-) + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/CHANGES + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/COPYING + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/README.md + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/README.scipy + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ccdotc.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cgetv0.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaitr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnapps.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaup2.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneigh.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cngets.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/csortc.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cstatn.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/debug.h + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dgetv0.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaitr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnapps.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaup2.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnconv.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneigh.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dngets.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaitr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsapps.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaup2.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsconv.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseigt.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsesrt.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsgets.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortc.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstatn.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstats.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstqrb.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sgetv0.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaitr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snapps.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaup2.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snconv.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneigh.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sngets.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaitr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssapps.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaup2.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssconv.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseigt.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssesrt.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssgets.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortc.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstatn.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstats.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstqrb.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/stat.h + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/version.h + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zgetv0.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaitr.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znapps.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaup2.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneigh.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneupd.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zngets.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zsortc.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zstatn.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zzdotc.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cmout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cvout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dmout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dvout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icnteq.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icopy.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iset.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iswap.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/ivout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/second_NONE.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/smout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/svout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zmout.f + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zvout.f + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack.h + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.c + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.h + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.c + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.h + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.c + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.h + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.c + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.h + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.c + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.h + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.c + create mode 100644 scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.h + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/README + create mode 100644 scipy/sparse/linalg/_eigen/arpack/_arpackmodule.c + delete mode 100644 scipy/sparse/linalg/_eigen/arpack/arpack.pyf.src + +diff --git a/scipy/sparse/linalg/_eigen/_svds.py b/scipy/sparse/linalg/_eigen/_svds.py +index ce57e841f9..99ae362e5c 100644 +--- a/scipy/sparse/linalg/_eigen/_svds.py ++++ b/scipy/sparse/linalg/_eigen/_svds.py +@@ -1,7 +1,5 @@ + import math + import numpy as np +- +-from .arpack import _arpack # type: ignore[attr-defined] + from . import eigsh + + from scipy._lib._util import check_random_state, _transition_to_rng +@@ -10,7 +8,6 @@ from scipy.sparse.linalg._eigen.lobpcg import lobpcg # type: ignore[no-redef] + from scipy.sparse.linalg._svdp import _svdp + from scipy.linalg import svd + +-arpack_int = _arpack.timing.nbx.dtype + __all__ = ['svds'] + + +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/CHANGES b/scipy/sparse/linalg/_eigen/arpack/ARPACK/CHANGES +deleted file mode 100644 +index 4ad3bd1602..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/CHANGES ++++ /dev/null +@@ -1,431 +0,0 @@ +-arpack-ng - 3.9.1 +- +-[ Fabien Péan ] +- * pyarpack: Ensure that the matrix properties (symmetric/hermitian) fit the solver (CG/LDL) with which they are used in the tests +- * [BUG FIX] Tests for PARPACK with C/C++ bindings icb_parpack_c and icb_parpack_cpp are now really parallel and split the problem across MPI processes. +- * Update arpackmm test suite: enable solving non-symmetric tests with BiCG solver +- * README: Add details on Windows installation. +- +-[ Szabolcs Horvát ] +- * [BUG FIX] Ensure that LAPACK RNG state is propagated (regression in 3.9.0). +- * [BUG FIX] Ensure that separate random seeds are used on different parallel thread in D and S versions of functions (issue from original ARPACK). +- +-[ Ruoyu Feng ] +- * ICB(arpackdef.h): distinct intel llvm compiler (icx with clang-cl) from msvc on windows +- * ICB(arpackdef.h): Undef macro I if complex.h from msvc version is loaded, which is an usual name and causes issues on arpackSolver. +- +-[ Franck Houssen ] +- * [BUG FIX] Fix install: headers in /path/to/local/include/arpack for ICB samples +- * [BUG FIX] Fix install: headers in /path/to/local/include/arpack +- * arpackmm: allow for using LA/SA magnitudes. +- * Rename icbexmm option into eigen option. +- * README: document how to use ICB. +- * [BUG FIX] arpackmm: fix restart. +- * README: document where to find arpack user's guide. +- +- -- Franck Houssen Sat, 14 Oct 2023 13:37:37 +0200 +- +-arpack-ng - 3.9.0 +- +-[ Vikas Sharma ] +- * Improve README. +- +-[ Fabien Péan ] +- * CI: Enable job `windows_latest_cmake` to run all tests +- * CMake: Fix BLAS and LAPACK static library order needed to consume the library on Windows with static linkage +- * Fix using ARPACK on Windows with MSVC compiler from C++17 onwards +- +-[ Zhentao Wang ] +- * [BUG FIX] parpack.h and parpack.hpp: type of rwork should be real instead of complex. +- * Allow ritz_option {"LR", "SR", "LI", "SI"} for complex eigenvalue problems in ICB. +- +-[ Jose E. Roman ] +- * Avoid using isnan() in tests, since is GNU-specific +- +-[ Tom Payerle ] +- * Change the continuation line format for stat.h, debug.h +- +-[ John Doe ] +- * Avoid calling [c|z]dotc for better portability on macOS +- +-[ Dima Pasechnik ] +- * [BUG FIX] autotools: replace obsolete AC_TRY_COMPILE macros. +- * Support for NAG's nagfor Fortran compiler +- +-[ Franck Houssen ] +- * Create one .cmake file per arpack-ng flavor (32-bits, 64-bits, ILP64). +- * Test autotools pkg-config (*.pc files) with/without LIBSUFFIX/ITF64SUFFIX. +- * Test CMake find_package (*.cmake files) with/without LIBSUFFIX/ITF64SUFFIX. +- * [BUG FIX] autotools: ICB must be checked first (MPI changes compilers). +- * [BUG FIX] BLAS/LAPACK: allow suffixes in case BLAS/LAPACK can not provide ICB. +- * [BUG FIX] Compile C programs with ICB. +- * arpackmm: command line bug fix. +- * arpackmm: restart bug fix. +- * pyarpack: fix compilation warning, test on macos and latest boost-python (1.79). +- * arpackSolver: fix error messages. +- * [BUG FIX] Make sure iseed is always initialized to values allowed by lapack ?larnv. +- * [BUG FIX] According to lapack doc of ?larnv, iseed(4) must be odd. +- * [BUG FIX] Use MPI ICB types (mpi_f08) instead of integer(kind=i_int). +- * parpack: no ILP64 support. +- +-[ Haoyang Liu ] +- * CMake: minimum required version changed to 3.0 +- * CMake: add C99 standard checking +- * CI: Support for centos7 added. +- * CI: Add `scripts/travis_centos.sh` for centos builds +- +-[ Robert Schütz ] +- * use CMAKE_INSTALL_FULL_ in arpack.pc +- +-[ Markus Mützel ] +- * CMake: Handle libraries without "lib" prefix. +- * CMake: Don't override BLAS/LAPACK/MPI flags. Directly use results from the Find* modules instead. +- +-[ Juan José García-Ripoll ] +- * Adapt the C/C++ interface to accept also MSVC's non-standard complex types. +- * Propagate dependencies to CMake targets that use arpack-ng: +- - Create CMake-generated targets and configuration files that keep track of +- arpack's dependencies (libraries, directories) and expose them to users. +- - Install those files under ${prefix}/lib/cmake/arpackng* so that arpack can be +- found using 'find_package(arpackng)' from CMake files. +- - Add code to the arpackng-config.cmake to find required dependencies when this +- module is loaded by find_package(arpackng). +- +- -- Sylvestre Ledru Mon, 07 Dec 2020 11:37:40 +0100 +- +-arpack-ng - 3.8.0 +- +-[ Myron Oikonomakis ] +- * [BUG FIX]: bmat return "G" instead of "B" for generalized matrix in arpack.hpp +- * [BUG FIX]: pass arrays of chars as scalar in fortran calls in order not to crash +- * when calling subroutines through icb interface +- +-[ Izaak "Zaak" Beekman ] +- * [BUG FIX]: fix 'Unknown CMake command "check_symbol_exists".' when ICB=ON. +- +-[ Franck Houssen ] +- * CI: Support for Mac OS X added in automation (GNU + "-ff2c -fno-second-underscore" options). +- * CI: Support for centos added in automation. +- * CI: Support for opensuse added in automation. +- * arpackSolver/arpackmm: switch eigen version to 3.3. +- * [BUG FIX] fix arpackdef.h (resp. arpackicb.h) must be included only by C/C++ (resp. F77/F90). +- * [BUG FIX] iparam/ipntr sizes may change depending on cases. +- * pyarpack: python binding based on Boost.Python.Numpy exposing C++ API. +- * [CLEAN] arpackSolver API: more convenient, suppress template parameters when possible. +- * [BUG FIX] ICB using rvec/select: rvec/select turned to integer +- bool should be, but, is not always supported (depend on compiler, options). +- * extract arpackSolver.hpp from arpakmm.cpp. +- * arpackmm: add --slvItrPC option (PC: Jacobi, ILU). +- * arpackmm: add --slv LLT LDLT (for SPD matrices). +- * arpackmm: add --simplePrec option (to enable use of s*upd). +- * arpackmm: add --dense option. +- * autotools: provide *.cmake files (in addition to *.pc file). +- * [BUG FIX] ILP64 support: using debug_c and stat_c. +- * [BUG FIX] fix check precision which may fail with some ATLAS versions. +- +-[ Kyle Guinn ] +- * [BUG FIX]: fix 'eval: Syntax error: "(" unexpected' error at build time. +- * Only build shared libraries by default. To build static libraries, use +- --enable-static (autotools) or -DBUILD_SHARED_LIBS=OFF (cmake). +- * Add parpack.pc and arpackSolver.pc. +- +-[ David Schwörer ] +- * Support of gfortran 10 +- +- -- Sylvestre Ledru Mon, 07 Dec 2020 11:35:57 +0100 +- +-arpack-ng - 3.7.0 +- +-[ Franck Houssen ] +- * [BUG FIX] ICB: missing workev for *[ds]neupd (real+not-sym) => API/ABI change for *[ds]neupd_c. +- * [BUG FIX] autotools - make distcheck: fix circular dependencies. +- * arpackmm: utility to test arpack with matrix market files. +- * ICB: add ILP64 support. +- The idea is: +- - autoheader/cmake generates arpackdef.h/arpackicb.h from arpackdef.h.in/arpackicb.h.in +- - in C/C++ files: arpackdef.h defines a_int according to architecture. +- - in F77/F90 files: arpackicb.h defines i_int to architecture. +- - MPI does not support ILP64: integer*4 must be imposed in all +- calls involving MPI (f90 example/test code). +- To enable ILP64 users to compile/link, arpackdef.h/arpackicb.h is added in +- the arpack installation (make install). +- +- [ Kyle Guinn ] +- * Autoconf/Automake simplifications and fixes. +- * Simplify the generation of arpackdef.h. +- +- -- Sylvestre Ledru Sat, 12 Jan 2019 16:24:00 +0100 +- +-arpack-ng - 3.6.3 +- +-[ Franck Houssen ] +- * Add Fortran common initialization (block data). +- +- [ Marco Caliari ] +- * Give up forcing the initial residual to be in the range of the operator OP after a restart (Closes: #142). +- +- -- Sylvestre Ledru Wed, 19 Sep 2018 09:59:59 +0200 +- +-arpack-ng - 3.6.2 +- +- * Remove all trailing whitespaces +- +- [ Franck Houssen ] +- * Install: move headers into a dedicated directory (local/include/arpack). +- (Closes #126) +- * Add configuration summary. +- * Improve the flag detection. Hopefully fix the ppc64el and other archs +- issues in Debian +- +- -- Sylvestre Ledru Sat, 23 Jun 2018 14:56:54 +0200 +- +-arpack-ng - 3.6.1 +- +- [ Ruslan Kabatsayev ] +- * Fix a regression on i386 and other archs (Closes #123) +- +- -- Sylvestre Ledru Thu Jun 7 21:41:16 2018 +0200 +- +-arpack-ng - 3.6.0 +- +- [ Franck Houssen ] +- * Add support for ISO_C_BINDING (Fortran 2003) for ARPACK, PARPACK (Fortran <-> C/C++). +- ARPACK: example of C/Fortran binding can be found in the TESTS/icb_arpack_c.c file. +- ARPACK: example of C++/Fortran binding can be found in the TESTS/icb_arpack_cpp.cpp file. +- PARPACK: example of C/Fortran binding can be found in the PARPACK/TESTS/MPI/icb_parpack_c.c file. +- PARPACK: example of C++/Fortran binding can be found in the PARPACK/TESTS/MPI/icb_parpack_cpp.cpp file. +- DEBUG: add support for debug. +- STAT: add support for statistics (timers, nb operations, ...). +- * Provide tarball generation using cmake (cpack). +- * Provide find_package for (cmake) users to find arpack-ng. +- +- [ Denis Davydov ] +- * Rename pslamch to pslamch10 to avoid symbol collision with Scalapack 2.0.2 in MPI context. +- +- [ Kyle Guinn ] +- * Autoconf cleanup; move generated files to the build-aux subdirectory. +- +- [ Marco Caliari ] +- * Force the initial residual to be in the range of the operator OP in the standard case, too (Closes: #79). +- +- [ Sylvestre Ledru ] +- * Add coverage information to improve testing: https://coveralls.io/github/opencollab/arpack-ng +- +- [ Darcy Beurle] +- * Add C++11 interface through arpack.hpp and parpack.hpp +- * Rewrite C++ examples / tests demonstrating new C++11 interface +- * Pre-C++11 interface available through arpack.h and parpack.h +- +- -- Sylvestre Ledru Mon, 30 Oct 2017 14:21:48 +0200 +- +-arpack-ng - 3.5.0 +- +- [ Julien Schueller ] +- * Improve cmake build system: disable C++ detection, set default build type. +- +- [ Marco Atzeri] +- * Use AC_PROG_FC instead of AC_PROG_F77 for proper inizialization +- for the usage of AC_FC_LINE_LENGTH. Noted on Cygwin. +- +- [ Denis Davydov ] +- * Improve cmake build system: add make install and fix shared libraries. +- +- [ Zhang Z ] +- * fix usages of DLACPY to not alias inputs +- (patch from https://software.intel.com/en-us/articles/how-to-resolve-arpack-issues-with-intel-mkl-110-update-3) +- +- [ Iskakov Sergei ] +- * Fix possible deadlock when PARPACK call uses communicator with a larger +- number of CPUs than previous call +- +- [ Kyle Guinn ] +- * Portability improvements to the autotools build system. +- * Let cmake guess the default installation directories. Can be +- overridden by changing CMAKE_INSTALL_LIBDIR and CMAKE_INSTALL_BINDIR. +- * Shared libraries built by cmake now have their SONAME set identical to +- those built by autotools. +- +- [ Marco Caliari ] +- * Avoid purification stage in [d,s]neupd.f if it requires division +- by zero (Closes: #58) +- +- -- Sylvestre Ledru Mon, 15 May 2017 14:21:48 +0200 +- +-arpack-ng - 3.4.0 +- +- [ Milan Bouchet-Valat ] +- * Allow adding suffixes to symbols and library names to build ILP64 version +- based on ILP64 BLAS/LAPACK with suffixes. This avoids conflicts when loading +- libraries with different integer sizes in the same program. +- +- [ Martin Reuter ] +- * Add the support of cmake build system +- +- -- Sylvestre Ledru Sat, 02 Jul 2016 21:51:52 +0200 +- +-arpack-ng - 3.3.0 +- +- [ Denis Davydov ] +- * Rename pdlamch to pdlamch10 to avoid symbol collision with Scalapack 2.0.2 in MPI context. +- +- [ Kyle Guinn ] +- * General improvements on the build system +- * libparpack links against libarpack (instead of doing a static link) +- +- [ Guillaume Horel ] +- * reverts using {d,s}lahqr from lapack 2 +- * use dlahqr from lapack 3 instead of dlaqrb (credit to Marco Caliari) +- +- -- Sylvestre Ledru Mon, 12 October 2015 08:40:51 +0200 +- +-arpack-ng - 3.2.0 +- +- * Switch to github - https://github.com/opencollab/arpack-ng/ +- +- * Fix dsneupd select/calculate wrong eigenpairs if rvec = true +- by using dlahqr and slahqr from lapack2 (Closes: #3) +- +- -- Sylvestre Ledru Sat, 14 Nov 2014 16:25:36 +0200 +- +-arpack-ng - 3.1.5 +- +- * Build all examples and run them as tests +- +- * Fix the version of arpack-ng itself +- +- * Switch to automake 1.14.1 +- +- [ Ruediger Meier ] +- * Do not install test binaries (Closes: #1348) +- +- [ Nikita Styopin ] +- * Fix the diagonal matrix example (dndrv5) (Closes: #1397) +- +- -- Sylvestre Ledru Sat, 15 Feb 2014 14:24:42 +0200 +- +-arpack-ng - 3.1.4 +- +- * libparpack2: missing dependency on MPI: +- http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=718790 +- +- * Replace LAPACK second function with ARPACK's own arscnd in PARPACK +- +- * Fix issue #1259 in DSEUPD and SSEUPD +- The Ritz vector purification step assumes workl(iq) still contains the +- original Q matrix. This is however overwritten by the call to xGEQR2 +- earlier. +- . +- This patch fixes the issue by making a copy of the last row of the +- eigenvector matrix, after it is recomputed after QR by xORM2R. The work +- space WORKL(IW+NCV:IW+2*NCV) is not used later in the routine, and can +- be used for this. +- +- * Use configure supplied blas and lapack in the pkg-config. +- Thanks to Ward Poelmans (Closes: #1320) +- +- * Switch to automake 1.14 + libtool 2.4.2. +- Thanks to Ward Poelmans (Closes: #1321) +- +- * dseupd routine may lead to a segmentation fault +- Thanks to Edouard Canot (Closes: #1323) +- +- * dsaupd and 'BE' option returns wrong eigenvalues for a SPD matrix +- Thanks to Edouard Canot (Closes: #1329) +- +- -- Sylvestre Ledru Mon, 07 Oct 2013 14:24:42 +0200 +- +-arpack-ng - 3.1.3 +- +- [ Jordi Gutiérrez Hermoso ] +- * Replace depcomp symlink with actual file. +- * Update libtool usage. Thanks to John W. Eaton . +- * Replace arpack.pc with proper autotooled arpack.pc.in +- * Add debug.h to TESTS/Makefile.am sources +- +- * "make dist" is functional +- * Also build the library "libparpacksrcblacs" (PARPACK/UTIL/BLACS/) +- +- -- Sylvestre Ledru Tue, 02 Apr 2013 10:53:08 +0200 +- +-arpack-ng - 3.1.2 +- +- * Wrong call to pdlamch was causing segfaults +- Thanks to Kyrre Sjøbæk for finding the bug and the fix. +- * Get rid of the mpif.h occurrences in the source code (Closes: #782) +- * Compile also PARPACK / MPI example (Closes: #783) +- * Configure detected built-in LAPACK and BLAS, but refused to use them +- (Closes: #784) +- * Fixed division by zero in smlnum by using p[d,s]lamch instead of the +- serial. Thanks to Umberto De Giovannini. +- +- -- Sylvestre Ledru Fri, 22 Jun 2012 22:05:41 +0200 +- +-arpack-ng - 3.1.1 +- +- * Option --enable-maintainer-mode added to the configure +- * --disable-mpi disables the build of parpack (Closes: #714) +- * Switch to automake 1.11.3 +- +- -- Sylvestre Ledru Mon, 21 May 2012 09:08:41 +0200 +- +-arpack-ng - 3.1.0 +- +- * Many bug fixes in the parpack lib. It is an old patch from upstream. +- Thanks to Viral Shah for pinging us on this subject. +- See the PARPACK_CHANGES file for the details. +- * Change the bug report from arpack@caam.rice.edu to +- http://forge.scilab.org/index.php/p/arpack-ng/issues/ +- * Provide a M4 macro (detect_arpack_bug.m4) to check if the underlying +- arpack is buggy (ie not arpack-ng). This allows developer applications +- to perform the check in their autotools build system (configure). +- * Fixed a lack of appropriate bounds check in DNAUP2. Thanks to Pauli Virtanen +- for the patch (Closes: #632) +- * Update of the doc about TOL in dnaupd. +- * Reorder bug fixed when eigenvectors are requested and the resulting +- number of converged eigenvalues is less than the number requested. +- Patches from Tim Mitchell. (Closes: #664) +- * TESTS/ directory added and built. +- +- -- Sylvestre Ledru Wed, 22 Feb 2012 10:58:39 +0100 +- +-arpack-ng - 3.0.2 +- +- * Fix a long line in pznaup2.f which was showing some wrong symbols +- (Closes: #620) +- * README content updated regarding ARPACK-NG +- * arpack.pc (pkg-config) file added +- * Update the title & version in the configure.ac +- * Always search for MPILIBS (in order to have the variable correctly set) +- * Explicitly link against MPI fortran libs for parpack +- +- -- Sylvestre Ledru Wed, 28 Dec 2011 13:45:53 +0100 +- +-arpack-ng - 3.0.1 +- +- * libtool was missing (Closes: #615) +- * Missing license information (Closes: #614) +- * TODO added +- +- -- Sylvestre Ledru Tue, 13 Dec 2011 16:33:25 +0100 +- +-arpack-ng - 3.0 +- +- * Patches from Scilab +- second_NONE used by default (TO DO replace by second in LAPACK) +- second_NONE works with all fortrans compilers (used by default with Scilab) +- +- sneupd.f, cneupd.f: modified for scilab add a check on nconv value (Scilab bug fix) +- dnaupd.f: modified NEV Integer: INPUT/OUTPUT before only INPUT (Scilab bug fix) +- +- * Patches from Octave: (Thanks to John W. EATON) +- dneupd.f: Restore value of nconv +- dseupd.f: Restore value of nconv +- sseupd.f: Change GOTO target to eliminate warning about landing on end if. +- zneupd.f: Restore value of nconv +- +- * Compilation +- Apply gentoo patches to use an autotools build system +- Build system updated to build with Visual Studio 2010 + Intel fortran 2011 compiles on Windows. +- Specify the SONAME to libarpack.so.2 (no API/ABI changes compare to version 2.0) +- +- -- Sylvestre Ledru Sat, 10 Dec 2011 20:32:45 +0100 +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/COPYING b/scipy/sparse/linalg/_eigen/arpack/ARPACK/COPYING +deleted file mode 100644 +index e87667e1b8..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/COPYING ++++ /dev/null +@@ -1,45 +0,0 @@ +- +-BSD Software License +- +-Pertains to ARPACK and P_ARPACK +- +-Copyright (c) 1996-2008 Rice University. +-Developed by D.C. Sorensen, R.B. Lehoucq, C. Yang, and K. Maschhoff. +-All rights reserved. +- +-Arpack has been renamed to arpack-ng. +- +-Copyright (c) 2001-2011 - Scilab Enterprises +-Updated by Allan Cornet, Sylvestre Ledru. +- +-Copyright (c) 2010 - Jordi Gutiérrez Hermoso (Octave patch) +- +-Copyright (c) 2007 - Sébastien Fabbro (gentoo patch) +- +-Redistribution and use in source and binary forms, with or without +-modification, are permitted provided that the following conditions are +-met: +- +-- Redistributions of source code must retain the above copyright +- notice, this list of conditions and the following disclaimer. +- +-- Redistributions in binary form must reproduce the above copyright +- notice, this list of conditions and the following disclaimer listed +- in this license in the documentation and/or other materials +- provided with the distribution. +- +-- Neither the name of the copyright holders nor the names of its +- contributors may be used to endorse or promote products derived from +- this software without specific prior written permission. +- +-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/README.md b/scipy/sparse/linalg/_eigen/arpack/ARPACK/README.md +deleted file mode 100644 +index a38fa76fd0..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/README.md ++++ /dev/null +@@ -1,376 +0,0 @@ +-# arpack-ng [![arpack-ng CI/CD](https://github.com/opencollab/arpack-ng/actions/workflows/jobs.yml/badge.svg)](https://github.com/opencollab/arpack-ng/actions/workflows/jobs.yml) +- +-ARPACK-NG is a collection of Fortran77 subroutines designed to solve large scale eigenvalue problems. +-| mandatory dependencies | optional dependencies | category | +-|------------------------|---------------------------|---------------| +-| BLAS, LAPACK | MPI, Eigen3, Boost.Python | LinearAlgebra | +- +-## About the project +- +-This project started as a joint project between Debian, Octave and Scilab in order to provide a common and maintained version of arpack. +-This is now a community project maintained by a few volunteers. +-Indeed, no single release has been published by Rice university for the last few years and since many software (Octave, Scilab, R, Matlab...) +-forked it and implemented their own modifications, arpack-ng aims to tackle this by providing a common repository, maintained versions with a testsuite. +-`arpack-ng` is replacing arpack almost everywhere. +- +-## Important Features +- +-- Reverse Communication Interface (RCI). +-- Single and Double Precision Real Arithmetic Versions for Symmetric, Non-symmetric, Standard or Generalized Problems. +-- Single and Double Precision Complex Arithmetic Versions for Standard or Generalized Problems. +-- Routines for Banded Matrices - Standard or Generalized Problems. +-- Routines for The Singular Value Decomposition. +-- Example driver routines that may be used as templates to implement numerous +-- Shift-Invert strategies for all problem types, data types and precision. +-- `arpackmm`: utility to test arpack with matrix market files. Note: to run this utility, you need the eigen library (to handle RCI). +- +-## Documentation +- +-Within DOCUMENTS directory there are three files for templates on how to invoke the computational modes of ARPACK. +- +-- ex-sym.doc +-- ex-nonsym.doc and +-- ex-complex.doc +- +-Also look in the README.MD file for explanations concerning the +-other documents. +- +-## ILP64 support +- +-About ILP64 support: +- +-- Sequential arpack supports [ILP64](https://www.intel.com/content/www/us/en/develop/documentation/onemkl-linux-developer-guide/top/linking-your-application-with-onemkl/linking-in-detail/linking-with-interface-libraries/using-the-ilp64-interface-vs-lp64-interface.html), but, parallel arpack doesn't. +-- Reminder: you can NOT mix `ILP64` with `LP64`. If you compile `arpack-ng` with `ILP64` (resp. `LP64`) support, you MUST insure your BLAS/LAPACK is compliant with `ILP64` (resp. `LP64`). +-- Set `INTERFACE64` at configure time. +- +-Note for F77/F90 developers: +- +-- All files which needs `ILP64` support must include `"arpackicb.h"`. +-- When coding, use `i_int` (defined in `arpackicb.h`) instead of `c_int`. `i_int` stands for ISO_C_BINDING integer: it's `#defined` to `c_int` or `c_int64_t` according to the architecture. +- +-Note for C/C++ developers: +- +-- All files which needs `ILP64` support must include `"arpackdef.h"`. +-- When coding, use `a_int` (defined in `arpackdef.h`) instead of `int`. Here, `a_int` stands for "architecture int": it's `#defined` to `int` or `int64_t` according to the architecture. +- +-**Example**: to test arpack with sequential `ILP64` MKL assuming you use gnu compilers +- +-```bash +-$ ./bootstrap +-$ export FFLAGS='-DMKL_ILP64 -I/usr/include/mkl' +-$ export FCFLAGS='-DMKL_ILP64 -I/usr/include/mkl' +-$ export LIBS='-Wl,--no-as-needed -L/usr/lib/x86_64-linux-gnu -lmkl_sequential -lmkl_core -lpthread -lm -ldl' +-$ export INTERFACE64=1 +-$ ./configure --with-blas=mkl_gf_ilp64 --with-lapack=mkl_gf_ilp64 +-$ make all check +-``` +- +-## ISO_C_BINDING support +- +-About ISO_C_BINDING support: +- +-- The install will now provide `arpack.h/hpp`, `parpack.h/hpp` and friends. +-- Examples of use can be found in `./TESTS` and` ./PARPACK/TESTS/MPI`. +- +-ISO_C_BINDING is a feature of modern Fortran meant to handle safely interoperability between Fortran and C (in practice, no more need to use ugly tricks to link F77 functions to C code using "underscored" symbols). Basically, ISO_C_BINDING make sure all fortran variables are typed (which may not always be the case when using `implicit` keyword in fortran): this way, C compilers can link properly. For more informations on ISO_C_BINDING, you can checkout the following links: +- +-- +-- +- +-Using ICB is seamless: +- +-- Compile `arpack-ng` with ISO_C_BINDING: you'll get both old-fashion fortran symbols and new ISO_C_BINDING symbols available for linking. +-- Add `#include "arpack.h"` in your C code. +-- Replace all [sdcz][ae]upd calls by [sdcz][ae]upd_c: functions suffixed with _c are ISO_C_BINDING compliant (exposing same arguments than original fortran functions). +- +-**Example**: to test arpack with ISO_C_BINDING +- +-```bash +-$ ./configure --enable-icb +-$ cmake -D ICB=ON +-``` +- +-## Eigen support +- +-`arpack-ng` provides C++ eigensolver based on both ISO_C_BINDING and `eigen`. +- +-Check out `./EXAMPLES/MATRIX_MARKET/README` for more details. +- +-**Example**: to test arpack with `eigen` +- +-```bash +-$ mkdir build +-$ cd build +-$ cmake -D EXAMPLES=ON -D ICB=ON -D EIGEN=ON .. +-$ make all check +-``` +- +-## Python support +- +-`pyarpack`: python support based on `Boost.Python.Numpy` exposing C++ API. +-`pyarpack` exposes in python the `arpack-ng` C++ eigensolver (based on `eigen`). +- +-Check out `./EXAMPLES/PYARPACK/README` for more details. +- +-**Example**: to test arpack with python3 +- +-```bash +-$ mkdir build +-$ cd build +-$ cmake -D EXAMPLES=ON -D ICB=ON -D EIGEN=ON -D PYTHON3=ON .. +-$ make all check +-``` +- +-## 📁 Directory structure +- +-- You have successfully unbundled ARPACK-NG` and are now in the ARPACK-NG directory that was created for you. +- +-- The directory SRC contains the top level routines including the highest level **reverse communication interface** routines +- +- - `ssaupd`, `dsaupd`: symmetric single and double precision +- - `snaupd`, `dnaupd`: non-symmetric single and double precision +- - `cnaupd`, `znaupd`: complex non-symmetric single and double precision +- - The headers of these routines contain full documentation of calling sequence and usage. +- - Additional information is given in the `/DOCUMENTS` directory. +- +-- The directory `PARPACK` contains the Parallel ARPACK routines. +- +-- Example driver programs that illustrate all the computational modes, data types and precisions may be found in the EXAMPLES directory. Upon executing the `ls EXAMPLES` command you should see the following directories +- +- ```bash +- ├── BAND +- ├── COMPLEX +- ├── Makefile.am +- ├── MATRIX_MARKET +- ├── NONSYM +- ├── PYARPACK +- ├── README +- ├── SIMPLE +- ├── SVD +- └── SYM +- ``` +- +- - Example programs for banded, complex, nonsymmetric, symmetric, and singular value decomposition may be found in the directories BAND, COMPLEX, NONSYM, SYM, SVD respectively. +- - Look at the README file for further information. +- - To get started, get into the SIMPLE directory to see example programs that illustrate the use of ARPACK in the simplest modes of operation for the most commonly posed standard eigenvalue problems. +- +-> Example programs for Parallel ARPACK may be found in the directory `PARPACK/EXAMPLES`. Look at the README file for further information. +- +-## Install 🚀 +- +-### Getting arpack-ng +- +-Unlike ARPACK, ARPACK-NG is providing autotools and cmake based build system. In addition, `ARPACK-NG` also provides +-ISO_C_BINDING support, which enables to call fortran subroutines natively from C or C++. +- +-First, obtain the source code 📥 from github: +- +-```bash +-$ git clone https://github.com/opencollab/arpack-ng.git +-$ cd ./arpack-ng +-``` +- +-If you prefer the ssh to obtain the source code, then use: +- +-```bash +-$ git clone git@github.com:opencollab/arpack-ng.git +-$ cd ./arpack-ng +-``` +- +-> Note, It is recommended to install `arpack` at standard location on your system by using your root privilege. +- +-### Using autotools +- +-In the source directory, use the following commands to configure, build and install `arpack-ng`. +- +-```bash +-$ sh bootstrap +-$ ./configure --enable-mpi +-$ make +-$ make check +-$ sudo make install +-``` +- +-Congratulations 🎉, you have installed `arpack` lib using autotools (caution: you need `sudo` to install in your system). +- +-The above-mentioned process will build everything including the examples and parallel support using MPI. +- +-### Using cmake +- +-You can install `ARPACK-NG` by using cmake. If you do not have cmake, then please download the binary from `pip` using: +- +-```bash +-$ python3 -m pip install cmake +-$ which cmake && cmake --version +-``` +- +-After installing cmake, follow the instruction given below. +- +-Caution: Make sure you are in source directory of ARPACK-NG. +- +-```bash +-$ mkdir build +-$ cd build +-$ cmake -D EXAMPLES=ON -D MPI=ON -D BUILD_SHARED_LIBS=ON .. +-$ make +-$ sudo make install +-``` +- +-✨ Congratulations, you have installed `arpack` lib using cmake (caution: you need `sudo` to install in your system). +- +-The above-mentioned process will build everything including the examples and parallel support using MPI. +- +-### Customize build / install +- +-You can also customize the installation of `arpack` using the autotools. +- +-To customize the install directories: +- +-```bash +-$ LIBSUFFIX="64" ./configure +-$ make all install +-``` +- +-To enable ILP64 support: +- +-```bash +-$ INTERFACE64="1" ITF64SUFFIX="ILP64" ./configure +-$ make all install +-``` +- +-To enable ISO_C_BINDING support: +- +-```bash +-$ ./configure --enable-icb +-``` +- +-You can customize the build by declaring the cmake options during configuration. +- +-To customize the install directories: +- +-```bash +-$ cmake -D LIBSUFFIX="64" .. +-$ make all install +-``` +- +-To enable ILP64 support: +- +-```bash +-$ cmake -D INTERFACE64=ON -D ITF64SUFFIX="ILP64" .. +-$ make all install +-``` +- +-To enable ISO_C_BINDING support: +- +-```bash +-$ cmake -D ICB=ON +-``` +- +-## Supported Operating Systems: +- +-### Linux support +- +-`arpack-ng` runs on debian-based distros. +- +-### Mac OS support +- +-On mac OS, with GNU compilers, you may need to customize options: +- +-```bash +-$ LIBS="-framework Accelerate" FFLAGS="-ff2c -fno-second-underscore" FCFLAGS="-ff2c -fno-second-underscore" ./configure +-``` +- +-### Windows support +- +-`arpack-ng` can be installed on Windows as a MinGW-w64 package via various distribution, for example through [MSYS2](https://packages.msys2.org/package/mingw-w64-x86_64-arpack) with `pacman -S mingw-w64-x86_64-arpack`. It can also be built and installed through [vcpkg](https://github.com/microsoft/vcpkg) with `vcpkg install arpack-ng`. +- +-## Using arpack-ng from your own codebase +- +-The `*.pc` and `*.cmake` files provided by `arpack-ng` are only pointing to arpack libraries. +-If you need other libraries (like MPI), you must add them alongside arpack (see CMake example below). +- +-Typically, if you need +- +-- ARPACK: at compile/link time, you'll need to provide BLAS and LAPACK. +- +-- ARPACK with eigen support (arpackSolver): at compile/link time, you'll need to provide BLAS, LAPACK and Eigen. +- +-- PARPACK: at compile/link time, you'll need to provide BLAS, LAPACK and MPI. +- +-Examples are provided in `tstCMakeInstall.sh` and `tstAutotoolsInstall.sh` generated after running cmake/configure. +- +-### With autotools +- +-First, set `PKG_CONFIG_PATH` to the location in the installation directory where `arpack.pc` lies. +- +-Then, insert the following lines in your `configure.ac`: +-``` +-PKG_CHECK_MODULES([ARPACK], [arpack]) +-AC_SUBST([ARPACK_CFLAGS]) +-AC_SUBST([ARPACK_LIBS]) +-``` +- +-Note: make sure you have installed `pkg-config`. +- +-### With CMake +- +-You can use arpack in your CMake builds by using `ARPACK::ARPACK` target. For example, +- +-```cmake +-FIND_PACKAGE(arpackng) +-ADD_EXECUTABLE(main main.f) +-TARGET_INCLUDE_DIRECTORIES(main PUBLIC ARPACK::ARPACK) +-TARGET_LINK_LIBRARIES(main ARPACK::ARPACK) +-``` +- +-To use PARPACK in your Cmake builds, use `PARPACK::PARPACK` target: +- +-```cmake +-FIND_PACKAGE(arpackng) +-FIND_PACKAGE(MPI REQUIRED COMPONENTS Fortran) +-ADD_EXECUTABLE(main main.f) +-TARGET_INCLUDE_DIRECTORIES(main PUBLIC PARPACK::PARPACK) +-TARGET_LINK_LIBRARIES(main PARPACK::PARPACK) +-TARGET_INCLUDE_DIRECTORIES(main PUBLIC MPI::MPI_Fortran) +-TARGET_LINK_LIBRARIES(main MPI::MPI_Fortran) +-``` +- +-Note: Make sure to update `CMAKE_MODULE_PATH` env variable (otheriwse, `find_package` won't find arpack-ng cmake file). +- +-### FAQ +- +-- Where can I find ARPACK user's guide? +- +- http://li.mit.edu/Archive/Activities/Archive/CourseWork/Ju_Li/MITCourses/18.335/Doc/ARPACK/Lehoucq97.pdf +- +-- Calling arpack's aupd methods returns `info = -9 - Starting vector is zero.`: why? +- +- Residuals are null. Try to set `resid` to small values (like epsilon machine magnitude) but *not exactly* zero. +- Residuals `resid = A*v - lamdba*v` target *exactly* the zero vector. +- When `resid` is close enough to zero, the iterative procedure stops. +- +-- Say I have an estimate of an eigen value, how to give this information to arpack? +- +- You need to shift of an amount of about this estimate of `lambda`. Grep `backTransform` in `arpackSolver.hpp` to see an example. +- For more informations, checkout "NUMERICAL METHODS FOR LARGE EIGENVALUE PROBLEMS" by Yousef Saad: https://www-users.cse.umn.edu/~saad/eig_book_2ndEd.pdf (paragraph 4.1.2. and section 4.1.). +- +-- Say I have an estimate of an eigen vector, how to give this information to arpack? +- +- You need to copy this eigen vector estimate in `v` (not `resid`) and set `info` to 1 before calling aupd methods. +- The `v` vector targets a non-null vector such that `resid = 0`, that is, such that `A*v = lambda*v`. +- +-- Using PARPACK, I get incorrect eigen values. +- +- Make sure each MPI processor handles a subpart of the eigen system (matrices) only. +- ARPACK handles and solves the whole eigen problem (matrices) at once. +- PARPACK doesn't: each MPI processor must handle and solve a subpart of the eigen system (matrices) only (independently from the other processors). +- See examples for Fortran in folder `PARPACK/EXAMPLES/MPI`, and for C/C++ examples in `PARPACK/TESTS/MPI/icb_parpack_c.c` and `PARPACK/TESTS/MPI/icb_parpack_cpp.cpp` +- +-## Using MKL instead of BLAS / LAPACK +- +-How to use arpack-ng with Intel MKL: +- +-- Let autotools/cmake find MKL for you based on pkg-config files (setting `PKG_CONFIG_PATH`) or cmake options (`BLA_VENDOR=Intel10_64lp` for lp64, `BLA_VENDOR=Intel10_64ilp` for ilp64). +-- Refers to the Intel Link Advisor: . +- +-## Good luck and enjoy 🎊 +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/README.scipy b/scipy/sparse/linalg/_eigen/arpack/ARPACK/README.scipy +deleted file mode 100644 +index eea037c4f9..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/README.scipy ++++ /dev/null +@@ -1,28 +0,0 @@ +-This directory contains a bundled version of ARPACK-NG 3.9.1, +-https://github.com/opencollab/arpack-ng +- +-NOTE FOR VENDORS: it is in general safe to use a system version of ARPACK +-instead. Note, however, that ARPACK and early versions of ARPACK-NG have +-certain bugs, so using those over the bundled version is not recommended. +- +-For versions of ARPACK-NG prior to 3.9.0, the bundled version has the +-following patch applied: +- +-Replace calls to certain Fortran functions with wrapper +-functions, to avoid various ABI mismatches on OSX. These changes are +-made with the following command: +- +-perl -pi -e ' +-s@\bcdotc\b@wcdotc@g; +-s@\bzdotc\b@wzdotc@g; +-s@\bcdotu\b@wcdotu@g; +-s@\bzdotu\b@wzdotu@g; +-s@\bcladiv\b@wcladiv@g; +-s@\bzladiv\b@wzladiv@g; +-s@\bslamch\b@slamch@g;' \ +-SRC/*.f UTIL/*.f +- +-For versions 3.9.0+, this is not necessary anymore and the issue is resolved +-via vendoring the copies of ccdotc and zzdotc. +- +-See https://github.com/opencollab/arpack-ng/pull/346 for more details. +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ccdotc.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ccdotc.f +deleted file mode 100644 +index f0f94f4223..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ccdotc.f ++++ /dev/null +@@ -1,36 +0,0 @@ +- complex function ccdotc(n,zx,incx,zy,incy) +-c +-c forms the dot product of a vector. +-c jack dongarra, 3/11/78. +-c modified 12/3/93, array(1) declarations changed to array(*) +-c +- complex zx(*),zy(*),ztemp +- integer i,incx,incy,ix,iy,n +- ztemp = (0.0d0,0.0d0) +- ccdotc = (0.0d0,0.0d0) +- if(n.le.0)return +- if(incx.eq.1.and.incy.eq.1)go to 20 +-c +-c code for unequal increments or equal increments +-c 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 +- do 10 i = 1,n +- ztemp = ztemp + conjg(zx(ix))*zy(iy) +- ix = ix + incx +- iy = iy + incy +- 10 continue +- ccdotc = ztemp +- return +-c +-c code for both increments equal to 1 +-c +- 20 do 30 i = 1,n +- ztemp = ztemp + conjg(zx(i))*zy(i) +- 30 continue +- ccdotc = ztemp +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cgetv0.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cgetv0.f +deleted file mode 100644 +index c231eadcb4..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cgetv0.f ++++ /dev/null +@@ -1,416 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cgetv0 +-c +-c\Description: +-c Generate a random initial residual vector for the Arnoldi process. +-c Force the residual vector to be in the range of the operator OP. +-c +-c\Usage: +-c call cgetv0 +-c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, +-c IPNTR, WORKD, IERR ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to cgetv0. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B in the (generalized) +-c eigenvalue problem A*x = lambda*B*x. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c ITRY Integer. (INPUT) +-c ITRY counts the number of times that cgetv0 is called. +-c It should be set to 1 on the initial call to cgetv0. +-c +-c INITV Logical variable. (INPUT) +-c .TRUE. => the initial residual vector is given in RESID. +-c .FALSE. => generate a random initial residual vector. +-c +-c N Integer. (INPUT) +-c Dimension of the problem. +-c +-c J Integer. (INPUT) +-c Index of the residual vector to be generated, with respect to +-c the Arnoldi process. J > 1 in case of a "restart". +-c +-c V Complex N by J array. (INPUT) +-c The first J-1 columns of V contain the current Arnoldi basis +-c if this is a "restart". +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c RESID Complex array of length N. (INPUT/OUTPUT) +-c Initial residual vector to be generated. If RESID is +-c provided, force RESID into the range of the operator OP. +-c +-c RNORM Real scalar. (OUTPUT) +-c B-norm of the generated residual. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c +-c WORKD Complex work array of length 2*N. (REVERSE COMMUNICATION). +-c On exit, WORK(1:N) = B*RESID to be used in SSAITR. +-c +-c IERR Integer. (OUTPUT) +-c = 0: Normal exit. +-c = -1: Cannot generate a nontrivial restarted residual vector +-c in the range of the operator OP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c cvout ARPACK utility routine that prints vectors. +-c clarnv LAPACK routine for generating a random vector. +-c cgemv Level 2 BLAS routine for matrix vector multiplication. +-c ccopy Level 1 BLAS that copies one vector to another. +-c cdotc Level 1 BLAS that computes the scalar product of two vectors. +-c scnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cgetv0 +- & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, +- & ipntr, workd, ierr ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- logical initv +- integer ido, ierr, itry, j, ldv, n +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Complex +- & resid(n), v(ldv,j), workd(2*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- Real +- & rzero +- parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), +- & rzero = 0.0E+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical first, inits, orth +- integer idist, iseed(4), iter, msglvl, jj +- Real +- & rnorm0 +- Complex +- & cnorm +- save first, iseed, inits, iter, msglvl, orth, rnorm0 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external ccopy, cgemv, clarnv, cvout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & scnrm2, slapy2 +- Complex +- & ccdotc +- external ccdotc, scnrm2, slapy2 +-c +-c %-----------------% +-c | Data Statements | +-c %-----------------% +-c +- data inits /.true./ +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c +-c %-----------------------------------% +-c | Initialize the seed of the LAPACK | +-c | random number generator | +-c %-----------------------------------% +-c +- if (inits) then +- iseed(1) = 1 +- iseed(2) = 3 +- iseed(3) = 5 +- iseed(4) = 7 +- inits = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mgetv0 +-c +- ierr = 0 +- iter = 0 +- first = .FALSE. +- orth = .FALSE. +-c +-c %-----------------------------------------------------% +-c | Possibly generate a random starting vector in RESID | +-c | Use a LAPACK random number generator used by the | +-c | matrix generation routines. | +-c | idist = 1: uniform (0,1) distribution; | +-c | idist = 2: uniform (-1,1) distribution; | +-c | idist = 3: normal (0,1) distribution; | +-c %-----------------------------------------------------% +-c +- if (.not.initv) then +- idist = 2 +- call clarnv (idist, iseed, n, resid) +- end if +-c +-c %----------------------------------------------------------% +-c | Force the starting vector into the range of OP to handle | +-c | the generalized problem when B is possibly (singular). | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (itry .eq. 1) then +- nopx = nopx + 1 +- ipntr(1) = 1 +- ipntr(2) = n + 1 +- call ccopy (n, resid, 1, workd, 1) +- ido = -1 +- go to 9000 +- else if (itry .gt. 1 .and. bmat .eq. 'G') then +- call ccopy (n, resid, 1, workd(n + 1), 1) +- end if +- end if +-c +-c %----------------------------------------% +-c | Back from computing OP*(initial-vector) | +-c %----------------------------------------% +-c +- if (first) go to 20 +-c +-c %-----------------------------------------------% +-c | Back from computing OP*(orthogonalized-vector) | +-c %-----------------------------------------------% +-c +- if (orth) go to 40 +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +-c +-c %------------------------------------------------------% +-c | Starting vector is now in the range of OP; r = OP*r; | +-c | Compute B-norm of starting vector. | +-c %------------------------------------------------------% +-c +- call arscnd (t2) +- first = .TRUE. +- if (itry .eq. 1) call ccopy (n, workd(n + 1), 1, resid, 1) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call ccopy (n, resid, 1, workd, 1) +- end if +-c +- 20 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- first = .FALSE. +- if (bmat .eq. 'G') then +- cnorm = ccdotc (n, resid, 1, workd, 1) +- rnorm0 = sqrt(slapy2(real(cnorm),aimag(cnorm))) +- else if (bmat .eq. 'I') then +- rnorm0 = scnrm2(n, resid, 1) +- end if +- rnorm = rnorm0 +-c +-c %---------------------------------------------% +-c | Exit if this is the very first Arnoldi step | +-c %---------------------------------------------% +-c +- if (j .eq. 1) go to 50 +-c +-c %---------------------------------------------------------------- +-c | Otherwise need to B-orthogonalize the starting vector against | +-c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | +-c | This is the case where an invariant subspace is encountered | +-c | in the middle of the Arnoldi factorization. | +-c | | +-c | s = V^{T}*B*r; r = r - V*s; | +-c | | +-c | Stopping criteria used for iter. ref. is discussed in | +-c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | +-c %---------------------------------------------------------------% +-c +- orth = .TRUE. +- 30 continue +-c +- call cgemv ('C', n, j-1, one, v, ldv, workd, 1, +- & zero, workd(n+1), 1) +- call cgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, +- & one, resid, 1) +-c +-c %----------------------------------------------------------% +-c | Compute the B-norm of the orthogonalized starting vector | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call ccopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call ccopy (n, resid, 1, workd, 1) +- end if +-c +- 40 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- cnorm = ccdotc (n, resid, 1, workd, 1) +- rnorm = sqrt(slapy2(real(cnorm),aimag(cnorm))) +- else if (bmat .eq. 'I') then +- rnorm = scnrm2(n, resid, 1) +- end if +-c +-c %--------------------------------------% +-c | Check for further orthogonalization. | +-c %--------------------------------------% +-c +- if (msglvl .gt. 2) then +- call svout (logfil, 1, [rnorm0], ndigit, +- & '_getv0: re-orthonalization ; rnorm0 is') +- call svout (logfil, 1, [rnorm], ndigit, +- & '_getv0: re-orthonalization ; rnorm is') +- end if +-c +- if (rnorm .gt. 0.717*rnorm0) go to 50 +-c +- iter = iter + 1 +- if (iter .le. 1) then +-c +-c %-----------------------------------% +-c | Perform iterative refinement step | +-c %-----------------------------------% +-c +- rnorm0 = rnorm +- go to 30 +- else +-c +-c %------------------------------------% +-c | Iterative refinement step "failed" | +-c %------------------------------------% +-c +- do 45 jj = 1, n +- resid(jj) = zero +- 45 continue +- rnorm = rzero +- ierr = -1 +- end if +-c +- 50 continue +-c +- if (msglvl .gt. 0) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_getv0: B-norm of initial / restarted starting vector') +- end if +- if (msglvl .gt. 2) then +- call cvout (logfil, n, resid, ndigit, +- & '_getv0: initial / restarted starting vector') +- end if +- ido = 99 +-c +- call arscnd (t1) +- tgetv0 = tgetv0 + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of cgetv0 | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaitr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaitr.f +deleted file mode 100644 +index 3759760dfb..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaitr.f ++++ /dev/null +@@ -1,850 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cnaitr +-c +-c\Description: +-c Reverse communication interface for applying NP additional steps to +-c a K step nonsymmetric Arnoldi factorization. +-c +-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +-c +-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +-c +-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +-c +-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +-c +-c where OP and B are as in cnaupd. The B-norm of r_{k+p} is also +-c computed and returned. +-c +-c\Usage: +-c call cnaitr +-c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c This is for the restart phase to force the new +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y, +-c IPNTR(3) is the pointer into WORK for B * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c When the routine is used in the "shift-and-invert" mode, the +-c vector B * Q is already available and do not need to be +-c recomputed in forming OP * Q. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. See cnaupd. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c K Integer. (INPUT) +-c Current size of V and H. +-c +-c NP Integer. (INPUT) +-c Number of additional Arnoldi steps to take. +-c +-c NB Integer. (INPUT) +-c Blocksize to be used in the recurrence. +-c Only work for NB = 1 right now. The goal is to have a +-c program that implement both the block and non-block method. +-c +-c RESID Complex array of length N. (INPUT/OUTPUT) +-c On INPUT: RESID contains the residual vector r_{k}. +-c On OUTPUT: RESID contains the residual vector r_{k+p}. +-c +-c RNORM Real scalar. (INPUT/OUTPUT) +-c B-norm of the starting residual on input. +-c B-norm of the updated residual r_{k+p} on output. +-c +-c V Complex N by K+NP array. (INPUT/OUTPUT) +-c On INPUT: V contains the Arnoldi vectors in the first K +-c columns. +-c On OUTPUT: V contains the new NP Arnoldi vectors in the next +-c NP columns. The first K columns are unchanged. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Complex (K+NP) by (K+NP) array. (INPUT/OUTPUT) +-c H is used to store the generated upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORK for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The calling program should not +-c use WORKD as temporary workspace during the iteration !!!!!! +-c On input, WORKD(1:N) = B*RESID and is used to save some +-c computation at the first step. +-c +-c INFO Integer. (OUTPUT) +-c = 0: Normal exit. +-c > 0: Size of the spanning invariant subspace of OP found. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c cgetv0 ARPACK routine to generate the initial vector. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c cmout ARPACK utility routine that prints matrices +-c cvout ARPACK utility routine that prints vectors. +-c clanhs LAPACK routine that computes various norms of a matrix. +-c clascl LAPACK routine for careful scaling of a matrix. +-c slabad LAPACK routine for defining the underflow and overflow +-c limits. +-c slamch LAPACK routine that determines machine constants. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c cgemv Level 2 BLAS routine for matrix vector multiplication. +-c caxpy Level 1 BLAS that computes a vector triad. +-c ccopy Level 1 BLAS that copies one vector to another . +-c cdotc Level 1 BLAS that computes the scalar product of two vectors. +-c cscal Level 1 BLAS that scales a vector. +-c csscal Level 1 BLAS that scales a complex vector by a real number. +-c scnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c The algorithm implemented is: +-c +-c restart = .false. +-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +-c r_{k} contains the initial residual vector even for k = 0; +-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +-c computed by the calling program. +-c +-c betaj = rnorm ; p_{k+1} = B*r_{k} ; +-c For j = k+1, ..., k+np Do +-c 1) if ( betaj < tol ) stop or restart depending on j. +-c ( At present tol is zero ) +-c if ( restart ) generate a new starting vector. +-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +-c p_{j} = p_{j}/betaj +-c 3) r_{j} = OP*v_{j} where OP is defined as in cnaupd +-c For shift-invert mode p_{j} = B*v_{j} is already available. +-c wnorm = || OP*v_{j} || +-c 4) Compute the j-th step residual vector. +-c w_{j} = V_{j}^T * B * OP * v_{j} +-c r_{j} = OP*v_{j} - V_{j} * w_{j} +-c H(:,j) = w_{j}; +-c H(j,j-1) = rnorm +-c rnorm = || r_(j) || +-c If (rnorm > 0.717*wnorm) accept step and go back to 1) +-c 5) Re-orthogonalization step: +-c s = V_{j}'*B*r_{j} +-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +-c alphaj = alphaj + s_{j}; +-c 6) Iterative refinement step: +-c If (rnorm1 > 0.717*rnorm) then +-c rnorm = rnorm1 +-c accept step and go back to 1) +-c Else +-c rnorm = rnorm1 +-c If this is the first time in step 6), go to 5) +-c Else r_{j} lies in the span of V_{j} numerically. +-c Set r_{j} = 0 and rnorm = 0; go to 1) +-c EndIf +-c End Do +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cnaitr +- & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, +- & ipntr, workd, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- integer ido, info, k, ldh, ldv, n, nb, np +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Complex +- & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- Real +- & rone, rzero +- parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), +- & rone = 1.0E+0, rzero = 0.0E+0) +-c +-c %--------------% +-c | Local Arrays | +-c %--------------% +-c +- Real +- & rtemp(2) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical first, orth1, orth2, rstart, step3, step4 +- integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, +- & jj +- Real +- & ovfl, smlnum, tst1, ulp, unfl, betaj, +- & temp1, rnorm1, wnorm +- Complex +- & cnorm +-c +- save first, orth1, orth2, rstart, step3, step4, +- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, +- & betaj, rnorm1, smlnum, ulp, unfl, wnorm +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external caxpy, ccopy, cscal, csscal, cgemv, cgetv0, +- & slabad, cvout, cmout, ivout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Complex +- & ccdotc +- Real +- & slamch, scnrm2, clanhs, slapy2 +- external ccdotc, scnrm2, clanhs, slamch, slapy2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic aimag, real, max, sqrt +-c +-c %-----------------% +-c | Data statements | +-c %-----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------% +-c | Set machine-dependent constants for the | +-c | the splitting and deflation criterion. | +-c | If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine clahqr | +-c %-----------------------------------------% +-c +- unfl = slamch( 'safe minimum' ) +- ovfl = real(one / unfl) +- call slabad( unfl, ovfl ) +- ulp = slamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mcaitr +-c +-c %------------------------------% +-c | Initial call to this routine | +-c %------------------------------% +-c +- info = 0 +- step3 = .false. +- step4 = .false. +- rstart = .false. +- orth1 = .false. +- orth2 = .false. +- j = k + 1 +- ipj = 1 +- irj = ipj + n +- ivj = irj + n +- end if +-c +-c %-------------------------------------------------% +-c | When in reverse communication mode one of: | +-c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +-c | will be .true. when .... | +-c | STEP3: return from computing OP*v_{j}. | +-c | STEP4: return from computing B-norm of OP*v_{j} | +-c | ORTH1: return from computing B-norm of r_{j+1} | +-c | ORTH2: return from computing B-norm of | +-c | correction to the residual vector. | +-c | RSTART: return from OP computations needed by | +-c | cgetv0. | +-c %-------------------------------------------------% +-c +- if (step3) go to 50 +- if (step4) go to 60 +- if (orth1) go to 70 +- if (orth2) go to 90 +- if (rstart) go to 30 +-c +-c %-----------------------------% +-c | Else this is the first step | +-c %-----------------------------% +-c +-c %--------------------------------------------------------------% +-c | | +-c | A R N O L D I I T E R A T I O N L O O P | +-c | | +-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +-c %--------------------------------------------------------------% +- +- 1000 continue +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: generating Arnoldi vector number') +- call svout (logfil, 1, [rnorm], ndigit, +- & '_naitr: B-norm of the current residual is') +- end if +-c +-c %---------------------------------------------------% +-c | STEP 1: Check if the B norm of j-th residual | +-c | vector is zero. Equivalent to determine whether | +-c | an exact j-step Arnoldi factorization is present. | +-c %---------------------------------------------------% +-c +- betaj = rnorm +- if (rnorm .gt. rzero) go to 40 +-c +-c %---------------------------------------------------% +-c | Invariant subspace found, generate a new starting | +-c | vector which is orthogonal to the current Arnoldi | +-c | basis and continue the iteration. | +-c %---------------------------------------------------% +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: ****** RESTART AT STEP ******') +- end if +-c +-c %---------------------------------------------% +-c | ITRY is the loop variable that controls the | +-c | maximum amount of times that a restart is | +-c | attempted. NRSTRT is used by stat.h | +-c %---------------------------------------------% +-c +- betaj = rzero +- nrstrt = nrstrt + 1 +- itry = 1 +- 20 continue +- rstart = .true. +- ido = 0 +- 30 continue +-c +-c %--------------------------------------% +-c | If in reverse communication mode and | +-c | RSTART = .true. flow returns here. | +-c %--------------------------------------% +-c +- call cgetv0 (ido, bmat, itry, .false., n, j, v, ldv, +- & resid, rnorm, ipntr, workd, ierr) +- if (ido .ne. 99) go to 9000 +- if (ierr .lt. 0) then +- itry = itry + 1 +- if (itry .le. 3) go to 20 +-c +-c %------------------------------------------------% +-c | Give up after several restart attempts. | +-c | Set INFO to the size of the invariant subspace | +-c | which spans OP and exit. | +-c %------------------------------------------------% +-c +- info = j - 1 +- call arscnd (t1) +- tcaitr = tcaitr + (t1 - t0) +- ido = 99 +- go to 9000 +- end if +-c +- 40 continue +-c +-c %---------------------------------------------------------% +-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +-c | when reciprocating a small RNORM, test against lower | +-c | machine bound. | +-c %---------------------------------------------------------% +-c +- call ccopy (n, resid, 1, v(1,j), 1) +- if ( rnorm .ge. unfl) then +- temp1 = rone / rnorm +- call csscal (n, temp1, v(1,j), 1) +- call csscal (n, temp1, workd(ipj), 1) +- else +-c +-c %-----------------------------------------% +-c | To scale both v_{j} and p_{j} carefully | +-c | use LAPACK routine clascl | +-c %-----------------------------------------% +-c +- call clascl ('General', i, i, rnorm, rone, +- & n, 1, v(1,j), n, infol) +- call clascl ('General', i, i, rnorm, rone, +- & n, 1, workd(ipj), n, infol) +- end if +-c +-c %------------------------------------------------------% +-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +-c | Note that this is not quite yet r_{j}. See STEP 4 | +-c %------------------------------------------------------% +-c +- step3 = .true. +- nopx = nopx + 1 +- call arscnd (t2) +- call ccopy (n, v(1,j), 1, workd(ivj), 1) +- ipntr(1) = ivj +- ipntr(2) = irj +- ipntr(3) = ipj +- ido = 1 +-c +-c %-----------------------------------% +-c | Exit in order to compute OP*v_{j} | +-c %-----------------------------------% +-c +- go to 9000 +- 50 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | +-c | if step3 = .true. | +-c %----------------------------------% +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +- +- step3 = .false. +-c +-c %------------------------------------------% +-c | Put another copy of OP*v_{j} into RESID. | +-c %------------------------------------------% +-c +- call ccopy (n, workd(irj), 1, resid, 1) +-c +-c %---------------------------------------% +-c | STEP 4: Finish extending the Arnoldi | +-c | factorization to length j. | +-c %---------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- step4 = .true. +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-------------------------------------% +-c | Exit in order to compute B*OP*v_{j} | +-c %-------------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call ccopy (n, resid, 1, workd(ipj), 1) +- end if +- 60 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | +-c | if step4 = .true. | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- step4 = .false. +-c +-c %-------------------------------------% +-c | The following is needed for STEP 5. | +-c | Compute the B-norm of OP*v_{j}. | +-c %-------------------------------------% +-c +- if (bmat .eq. 'G') then +- cnorm = ccdotc (n, resid, 1, workd(ipj), 1) +- wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) +- else if (bmat .eq. 'I') then +- wnorm = scnrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------% +-c | Compute the j-th residual corresponding | +-c | to the j step factorization. | +-c | Use Classical Gram Schmidt and compute: | +-c | w_{j} <- V_{j}^T * B * OP * v_{j} | +-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +-c %-----------------------------------------% +-c +-c +-c %------------------------------------------% +-c | Compute the j Fourier coefficients w_{j} | +-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +-c %------------------------------------------% +-c +- call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, +- & zero, h(1,j), 1) +-c +-c %--------------------------------------% +-c | Orthogonalize r_{j} against V_{j}. | +-c | RESID contains OP*v_{j}. See STEP 3. | +-c %--------------------------------------% +-c +- call cgemv ('N', n, j, -one, v, ldv, h(1,j), 1, +- & one, resid, 1) +-c +- if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero) +-c +- call arscnd (t4) +-c +- orth1 = .true. +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call ccopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*r_{j} | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call ccopy (n, resid, 1, workd(ipj), 1) +- end if +- 70 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH1 = .true. | +-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- orth1 = .false. +-c +-c %------------------------------% +-c | Compute the B-norm of r_{j}. | +-c %------------------------------% +-c +- if (bmat .eq. 'G') then +- cnorm = ccdotc (n, resid, 1, workd(ipj), 1) +- rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) +- else if (bmat .eq. 'I') then +- rnorm = scnrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------------------------% +-c | STEP 5: Re-orthogonalization / Iterative refinement phase | +-c | Maximum NITER_ITREF tries. | +-c | | +-c | s = V_{j}^T * B * r_{j} | +-c | r_{j} = r_{j} - V_{j}*s | +-c | alphaj = alphaj + s_{j} | +-c | | +-c | The stopping criteria used for iterative refinement is | +-c | discussed in Parlett's book SEP, page 107 and in Gragg & | +-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +-c | Determine if we need to correct the residual. The goal is | +-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +-c | The following test determines whether the sine of the | +-c | angle between OP*x and the computed residual is less | +-c | than or equal to 0.717. | +-c %-----------------------------------------------------------% +-c +- if ( rnorm .gt. 0.717*wnorm ) go to 100 +-c +- iter = 0 +- nrorth = nrorth + 1 +-c +-c %---------------------------------------------------% +-c | Enter the Iterative refinement phase. If further | +-c | refinement is necessary, loop back here. The loop | +-c | variable is ITER. Perform a step of Classical | +-c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +-c %---------------------------------------------------% +-c +- 80 continue +-c +- if (msglvl .gt. 2) then +- rtemp(1) = wnorm +- rtemp(2) = rnorm +- call svout (logfil, 2, rtemp, ndigit, +- & '_naitr: re-orthogonalization; wnorm and rnorm are') +- call cvout (logfil, j, h(1,j), ndigit, +- & '_naitr: j-th column of H') +- end if +-c +-c %----------------------------------------------------% +-c | Compute V_{j}^T * B * r_{j}. | +-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +-c %----------------------------------------------------% +-c +- call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, +- & zero, workd(irj), 1) +-c +-c %---------------------------------------------% +-c | Compute the correction to the residual: | +-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +-c | The correction to H is v(:,1:J)*H(1:J,1:J) | +-c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | +-c %---------------------------------------------% +-c +- call cgemv ('N', n, j, -one, v, ldv, workd(irj), 1, +- & one, resid, 1) +- call caxpy (j, one, workd(irj), 1, h(1,j), 1) +-c +- orth2 = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call ccopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-----------------------------------% +-c | Exit in order to compute B*r_{j}. | +-c | r_{j} is the corrected residual. | +-c %-----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call ccopy (n, resid, 1, workd(ipj), 1) +- end if +- 90 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH2 = .true. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +-c %-----------------------------------------------------% +-c | Compute the B-norm of the corrected residual r_{j}. | +-c %-----------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- cnorm = ccdotc (n, resid, 1, workd(ipj), 1) +- rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) +- else if (bmat .eq. 'I') then +- rnorm1 = scnrm2(n, resid, 1) +- end if +-c +- if (msglvl .gt. 0 .and. iter .gt. 0 ) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: Iterative refinement for Arnoldi residual') +- if (msglvl .gt. 2) then +- rtemp(1) = rnorm +- rtemp(2) = rnorm1 +- call svout (logfil, 2, rtemp, ndigit, +- & '_naitr: iterative refinement ; rnorm and rnorm1 are') +- end if +- end if +-c +-c %-----------------------------------------% +-c | Determine if we need to perform another | +-c | step of re-orthogonalization. | +-c %-----------------------------------------% +-c +- if ( rnorm1 .gt. 0.717*rnorm ) then +-c +-c %---------------------------------------% +-c | No need for further refinement. | +-c | The cosine of the angle between the | +-c | corrected residual vector and the old | +-c | residual vector is greater than 0.717 | +-c | In other words the corrected residual | +-c | and the old residual vector share an | +-c | angle of less than arcCOS(0.717) | +-c %---------------------------------------% +-c +- rnorm = rnorm1 +-c +- else +-c +-c %-------------------------------------------% +-c | Another step of iterative refinement step | +-c | is required. NITREF is used by stat.h | +-c %-------------------------------------------% +-c +- nitref = nitref + 1 +- rnorm = rnorm1 +- iter = iter + 1 +- if (iter .le. 1) go to 80 +-c +-c %-------------------------------------------------% +-c | Otherwise RESID is numerically in the span of V | +-c %-------------------------------------------------% +-c +- do 95 jj = 1, n +- resid(jj) = zero +- 95 continue +- rnorm = rzero +- end if +-c +-c %----------------------------------------------% +-c | Branch here directly if iterative refinement | +-c | wasn't necessary or after at most NITER_REF | +-c | steps of iterative refinement. | +-c %----------------------------------------------% +-c +- 100 continue +-c +- rstart = .false. +- orth2 = .false. +-c +- call arscnd (t5) +- titref = titref + (t5 - t4) +-c +-c %------------------------------------% +-c | STEP 6: Update j = j+1; Continue | +-c %------------------------------------% +-c +- j = j + 1 +- if (j .gt. k+np) then +- call arscnd (t1) +- tcaitr = tcaitr + (t1 - t0) +- ido = 99 +- do 110 i = max(1,k), k+np-1 +-c +-c %--------------------------------------------% +-c | Check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine clahqr | +-c %--------------------------------------------% +-c +- tst1 = slapy2(real(h(i,i)),aimag(h(i,i))) +- & + slapy2(real(h(i+1,i+1)), aimag(h(i+1,i+1))) +- if( tst1.eq.real(zero) ) +- & tst1 = clanhs( '1', k+np, h, ldh, workd(n+1) ) +- if( slapy2(real(h(i+1,i)),aimag(h(i+1,i))) .le. +- & max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 110 continue +-c +- if (msglvl .gt. 2) then +- call cmout (logfil, k+np, k+np, h, ldh, ndigit, +- & '_naitr: Final upper Hessenberg matrix H of order K+NP') +- end if +-c +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Loop back to extend the factorization by another step. | +-c %--------------------------------------------------------% +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of cnaitr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnapps.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnapps.f +deleted file mode 100644 +index c3a55623f8..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnapps.f ++++ /dev/null +@@ -1,507 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cnapps +-c +-c\Description: +-c Given the Arnoldi factorization +-c +-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +-c +-c apply NP implicit shifts resulting in +-c +-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +-c +-c where Q is an orthogonal matrix which is the product of rotations +-c and reflections resulting from the NP bulge change sweeps. +-c The updated Arnoldi factorization becomes: +-c +-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +-c +-c\Usage: +-c call cnapps +-c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, +-c WORKL, WORKD ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Problem size, i.e. size of matrix A. +-c +-c KEV Integer. (INPUT/OUTPUT) +-c KEV+NP is the size of the input matrix H. +-c KEV is the size of the updated matrix HNEW. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be applied. +-c +-c SHIFT Complex array of length NP. (INPUT) +-c The shifts to be applied. +-c +-c V Complex N by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, V contains the current KEV+NP Arnoldi vectors. +-c On OUTPUT, V contains the updated KEV Arnoldi vectors +-c in the first KEV columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Complex (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, H contains the current KEV+NP by KEV+NP upper +-c Hessenberg matrix of the Arnoldi factorization. +-c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg +-c matrix in the KEV leading submatrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RESID Complex array of length N. (INPUT/OUTPUT) +-c On INPUT, RESID contains the the residual vector r_{k+p}. +-c On OUTPUT, RESID is the update residual vector rnew_{k} +-c in the first KEV locations. +-c +-c Q Complex KEV+NP by KEV+NP work array. (WORKSPACE) +-c Work array used to accumulate the rotations and reflections +-c during the bulge chase sweep. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Complex work array of length (KEV+NP). (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c WORKD Complex work array of length 2*N. (WORKSPACE) +-c Distributed array used in the application of the accumulated +-c orthogonal matrix Q. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c cmout ARPACK utility routine that prints matrices +-c cvout ARPACK utility routine that prints vectors. +-c clacpy LAPACK matrix copy routine. +-c clanhs LAPACK routine that computes various norms of a matrix. +-c clartg LAPACK Givens rotation construction routine. +-c claset LAPACK matrix initialization routine. +-c slabad LAPACK routine for defining the underflow and overflow +-c limits. +-c slamch LAPACK routine that determines machine constants. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c cgemv Level 2 BLAS routine for matrix vector multiplication. +-c caxpy Level 1 BLAS that computes a vector triad. +-c ccopy Level 1 BLAS that copies one vector to another. +-c cscal Level 1 BLAS that scales a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 +-c +-c\Remarks +-c 1. In this version, each shift is applied to all the sublocks of +-c the Hessenberg matrix H and not just to the submatrix that it +-c comes from. Deflation as in LAPACK routine clahqr (QR algorithm +-c for upper Hessenberg matrices ) is used. +-c Upon output, the subdiagonals of H are enforced to be non-negative +-c real numbers. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cnapps +- & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, +- & workl, workd ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer kev, ldh, ldq, ldv, n, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex +- & h(ldh,kev+np), resid(n), shift(np), +- & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- Real +- & rzero +- parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), +- & rzero = 0.0E+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- integer i, iend, istart, j, jj, kplusp, msglvl +- logical first +- Complex +- & cdum, f, g, h11, h21, r, s, sigma, t +- Real +- & c, ovfl, smlnum, ulp, unfl, tst1 +- save first, ovfl, smlnum, ulp, unfl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external caxpy, ccopy, cgemv, cscal, clacpy, clartg, +- & cvout, claset, slabad, cmout, arscnd, ivout +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & clanhs, slamch, slapy2 +- external clanhs, slamch, slapy2 +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs, aimag, conjg, cmplx, max, min, real +-c +-c %---------------------% +-c | Statement Functions | +-c %---------------------% +-c +- Real +- & cabs1 +- cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) +-c +-c %----------------% +-c | Data statements | +-c %----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------------% +-c | Set machine-dependent constants for the | +-c | stopping criterion. If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine clahqr | +-c %-----------------------------------------------% +-c +- unfl = slamch( 'safe minimum' ) +- ovfl = real(one / unfl) +- call slabad( unfl, ovfl ) +- ulp = slamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mcapps +-c +- kplusp = kev + np +-c +-c %--------------------------------------------% +-c | Initialize Q to the identity to accumulate | +-c | the rotations and reflections | +-c %--------------------------------------------% +-c +- call claset ('All', kplusp, kplusp, zero, one, q, ldq) +-c +-c %----------------------------------------------% +-c | Quick return if there are no shifts to apply | +-c %----------------------------------------------% +-c +- if (np .eq. 0) go to 9000 +-c +-c %----------------------------------------------% +-c | Chase the bulge with the application of each | +-c | implicit shift. Each shift is applied to the | +-c | whole matrix including each block. | +-c %----------------------------------------------% +-c +- do 110 jj = 1, np +- sigma = shift(jj) +-c +- if (msglvl .gt. 2 ) then +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: shift number.') +- call cvout (logfil, 1, [sigma], ndigit, +- & '_napps: Value of the shift ') +- end if +-c +- istart = 1 +- 20 continue +-c +- do 30 i = istart, kplusp-1 +-c +-c %----------------------------------------% +-c | Check for splitting and deflation. Use | +-c | a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine clahqr | +-c %----------------------------------------% +-c +- tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) +- if( tst1.eq.rzero ) +- & tst1 = clanhs( '1', kplusp-jj+1, h, ldh, workl ) +- if ( abs(real(h(i+1,i))) +- & .le. max(ulp*tst1, smlnum) ) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_napps: matrix splitting at row/column no.') +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: matrix splitting with shift number.') +- call cvout (logfil, 1, h(i+1,i), ndigit, +- & '_napps: off diagonal element.') +- end if +- iend = i +- h(i+1,i) = zero +- go to 40 +- end if +- 30 continue +- iend = kplusp +- 40 continue +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [istart], ndigit, +- & '_napps: Start of current block ') +- call ivout (logfil, 1, [iend], ndigit, +- & '_napps: End of current block ') +- end if +-c +-c %------------------------------------------------% +-c | No reason to apply a shift to block of order 1 | +-c | or if the current block starts after the point | +-c | of compression since we'll discard this stuff | +-c %------------------------------------------------% +-c +- if ( istart .eq. iend .or. istart .gt. kev) go to 100 +-c +- h11 = h(istart,istart) +- h21 = h(istart+1,istart) +- f = h11 - sigma +- g = h21 +-c +- do 80 i = istart, iend-1 +-c +-c %------------------------------------------------------% +-c | Construct the plane rotation G to zero out the bulge | +-c %------------------------------------------------------% +-c +- call clartg (f, g, c, s, r) +- if (i .gt. istart) then +- h(i,i-1) = r +- h(i+1,i-1) = zero +- end if +-c +-c %---------------------------------------------% +-c | Apply rotation to the left of H; H <- G'*H | +-c %---------------------------------------------% +-c +- do 50 j = i, kplusp +- t = c*h(i,j) + s*h(i+1,j) +- h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) +- h(i,j) = t +- 50 continue +-c +-c %---------------------------------------------% +-c | Apply rotation to the right of H; H <- H*G | +-c %---------------------------------------------% +-c +- do 60 j = 1, min(i+2,iend) +- t = c*h(j,i) + conjg(s)*h(j,i+1) +- h(j,i+1) = -s*h(j,i) + c*h(j,i+1) +- h(j,i) = t +- 60 continue +-c +-c %-----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G' | +-c %-----------------------------------------------------% +-c +- do 70 j = 1, min(i+jj, kplusp) +- t = c*q(j,i) + conjg(s)*q(j,i+1) +- q(j,i+1) = - s*q(j,i) + c*q(j,i+1) +- q(j,i) = t +- 70 continue +-c +-c %---------------------------% +-c | Prepare for next rotation | +-c %---------------------------% +-c +- if (i .lt. iend-1) then +- f = h(i+1,i) +- g = h(i+2,i) +- end if +- 80 continue +-c +-c %-------------------------------% +-c | Finished applying the shift. | +-c %-------------------------------% +-c +- 100 continue +-c +-c %---------------------------------------------------------% +-c | Apply the same shift to the next block if there is any. | +-c %---------------------------------------------------------% +-c +- istart = iend + 1 +- if (iend .lt. kplusp) go to 20 +-c +-c %---------------------------------------------% +-c | Loop back to the top to get the next shift. | +-c %---------------------------------------------% +-c +- 110 continue +-c +-c %---------------------------------------------------% +-c | Perform a similarity transformation that makes | +-c | sure that the compressed H will have non-negative | +-c | real subdiagonal elements. | +-c %---------------------------------------------------% +-c +- do 120 j=1,kev +- if ( real( h(j+1,j) ) .lt. rzero .or. +- & aimag( h(j+1,j) ) .ne. rzero ) then +- t = h(j+1,j) / slapy2(real(h(j+1,j)),aimag(h(j+1,j))) +- call cscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) +- call cscal( min(j+2, kplusp), t, h(1,j+1), 1 ) +- call cscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) +- h(j+1,j) = cmplx( real( h(j+1,j) ), rzero ) +- end if +- 120 continue +-c +- do 130 i = 1, kev +-c +-c %--------------------------------------------% +-c | Final check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine clahqr. | +-c | Note: Since the subdiagonals of the | +-c | compressed H are nonnegative real numbers, | +-c | we take advantage of this. | +-c %--------------------------------------------% +-c +- tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) +- if( tst1 .eq. rzero ) +- & tst1 = clanhs( '1', kev, h, ldh, workl ) +- if( real( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 130 continue +-c +-c %-------------------------------------------------% +-c | Compute the (kev+1)-st column of (V*Q) and | +-c | temporarily store the result in WORKD(N+1:2*N). | +-c | This is needed in the residual update since we | +-c | cannot GUARANTEE that the corresponding entry | +-c | of H would be zero as in exact arithmetic. | +-c %-------------------------------------------------% +-c +- if ( real( h(kev+1,kev) ) .gt. rzero ) +- & call cgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, +- & workd(n+1), 1) +-c +-c %----------------------------------------------------------% +-c | Compute column 1 to kev of (V*Q) in backward order | +-c | taking advantage of the upper Hessenberg structure of Q. | +-c %----------------------------------------------------------% +-c +- do 140 i = 1, kev +- call cgemv ('N', n, kplusp-i+1, one, v, ldv, +- & q(1,kev-i+1), 1, zero, workd, 1) +- call ccopy (n, workd, 1, v(1,kplusp-i+1), 1) +- 140 continue +-c +-c %-------------------------------------------------% +-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +-c %-------------------------------------------------% +-c +- call clacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) +-c +-c %--------------------------------------------------------------% +-c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | +-c %--------------------------------------------------------------% +-c +- if ( real( h(kev+1,kev) ) .gt. rzero ) +- & call ccopy (n, workd(n+1), 1, v(1,kev+1), 1) +-c +-c %-------------------------------------% +-c | Update the residual vector: | +-c | r <- sigmak*r + betak*v(:,kev+1) | +-c | where | +-c | sigmak = (e_{kev+p}'*Q)*e_{kev} | +-c | betak = e_{kev+1}'*H*e_{kev} | +-c %-------------------------------------% +-c +- call cscal (n, q(kplusp,kev), resid, 1) +- if ( real( h(kev+1,kev) ) .gt. rzero ) +- & call caxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) +-c +- if (msglvl .gt. 1) then +- call cvout (logfil, 1, q(kplusp,kev), ndigit, +- & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') +- call cvout (logfil, 1, h(kev+1,kev), ndigit, +- & '_napps: betak = e_{kev+1}^T*H*e_{kev}') +- call ivout (logfil, 1, [kev], ndigit, +- & '_napps: Order of the final Hessenberg matrix ') +- if (msglvl .gt. 2) then +- call cmout (logfil, kev, kev, h, ldh, ndigit, +- & '_napps: updated Hessenberg matrix H for next iteration') +- end if +-c +- end if +-c +- 9000 continue +- call arscnd (t1) +- tcapps = tcapps + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of cnapps | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaup2.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaup2.f +deleted file mode 100644 +index e361542472..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaup2.f ++++ /dev/null +@@ -1,801 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cnaup2 +-c +-c\Description: +-c Intermediate level interface called by cnaupd. +-c +-c\Usage: +-c call cnaup2 +-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +-c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, +-c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) +-c +-c\Arguments +-c +-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in cnaupd. +-c MODE, ISHIFT, MXITER: see the definition of IPARAM in cnaupd. +-c +-c NP Integer. (INPUT/OUTPUT) +-c Contains the number of implicit shifts to apply during +-c each Arnoldi iteration. +-c If ISHIFT=1, NP is adjusted dynamically at each iteration +-c to accelerate convergence and prevent stagnation. +-c This is also roughly equal to the number of matrix-vector +-c products (involving the operator OP) per Arnoldi iteration. +-c The logic for adjusting is contained within the current +-c subroutine. +-c If ISHIFT=0, NP is the number of shifts the user needs +-c to provide via reverse communication. 0 < NP < NCV-NEV. +-c NP may be less than NCV-NEV since a leading block of the current +-c upper Hessenberg matrix has split off and contains "unwanted" +-c Ritz values. +-c Upon termination of the IRA iteration, NP contains the number +-c of "converged" wanted Ritz values. +-c +-c IUPD Integer. (INPUT) +-c IUPD .EQ. 0: use explicit restart instead implicit update. +-c IUPD .NE. 0: use implicit update. +-c +-c V Complex N by (NEV+NP) array. (INPUT/OUTPUT) +-c The Arnoldi basis vectors are returned in the first NEV +-c columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Complex (NEV+NP) by (NEV+NP) array. (OUTPUT) +-c H is used to store the generated upper Hessenberg matrix +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZ Complex array of length NEV+NP. (OUTPUT) +-c RITZ(1:NEV) contains the computed Ritz values of OP. +-c +-c BOUNDS Complex array of length NEV+NP. (OUTPUT) +-c BOUNDS(1:NEV) contain the error bounds corresponding to +-c the computed Ritz values. +-c +-c Q Complex (NEV+NP) by (NEV+NP) array. (WORKSPACE) +-c Private (replicated) work array used to accumulate the +-c rotation in the shift application step. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Complex work array of length at least +-c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. It is used in shifts calculation, shifts +-c application and convergence checking. +-c +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Complex work array of length 3*N. (WORKSPACE) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note in CNAUPD. +-c +-c RWORK Real work array of length NEV+NP ( WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal return. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. +-c NP returns the number of converged Ritz values. +-c = 2: No shifts could be applied. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c This should never happen. +-c = -9: Starting vector is zero. +-c = -9999: Could not build an Arnoldi factorization. +-c Size that was built in returned in NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c cgetv0 ARPACK initial vector generation routine. +-c cnaitr ARPACK Arnoldi factorization routine. +-c cnapps ARPACK application of implicit shifts routine. +-c cneigh ARPACK compute Ritz values and error bounds routine. +-c cngets ARPACK reorder Ritz values and error bounds routine. +-c csortc ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c cmout ARPACK utility routine that prints matrices +-c cvout ARPACK utility routine that prints vectors. +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c ccopy Level 1 BLAS that copies one vector to another . +-c cdotc Level 1 BLAS that computes the scalar product of two vectors. +-c cswap Level 1 BLAS that swaps two vectors. +-c scnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice Universitya +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 +-c +-c\Remarks +-c 1. None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cnaup2 +- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, +- & q, ldq, workl, ipntr, workd, rwork, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, +- & n, nev, np +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(13) +- Complex +- & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), +- & resid(n), ritz(nev+np), v(ldv,nev+np), +- & workd(3*n), workl( (nev+np)*(nev+np+3) ) +- Real +- & rwork(nev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- Real +- & rzero +- parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) , +- & rzero = 0.0E+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical cnorm , getv0, initv , update, ushift +- integer ierr , iter , kplusp, msglvl, nconv, +- & nevbef, nev0 , np0 , nptemp, i , +- & j +- Complex +- & cmpnorm +- Real +- & rnorm , eps23, rtemp +- character wprime*2 +-c +- save cnorm, getv0, initv , update, ushift, +- & rnorm, iter , kplusp, msglvl, nconv , +- & nevbef, nev0 , np0 , eps23 +-c +-c +-c %-----------------------% +-c | Local array arguments | +-c %-----------------------% +-c +- integer kp(3) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external ccopy, cgetv0, cnaitr, cneigh, cngets, cnapps, +- & csortc, cswap, cmout, cvout, ivout, arscnd +-c +-c %--------------------% +-c | External functions | +-c %--------------------% +-c +- Complex +- & ccdotc +- Real +- & scnrm2, slamch, slapy2 +- external ccdotc, scnrm2, slamch, slapy2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic aimag, real , min, max +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +- call arscnd (t0) +-c +- msglvl = mcaup2 +-c +- nev0 = nev +- np0 = np +-c +-c %-------------------------------------% +-c | kplusp is the bound on the largest | +-c | Lanczos factorization built. | +-c | nconv is the current number of | +-c | "converged" eigenvalues. | +-c | iter is the counter on the current | +-c | iteration step. | +-c %-------------------------------------% +-c +- kplusp = nev + np +- nconv = 0 +- iter = 0 +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0 ) +-c +-c %---------------------------------------% +-c | Set flags for computing the first NEV | +-c | steps of the Arnoldi factorization. | +-c %---------------------------------------% +-c +- getv0 = .true. +- update = .false. +- ushift = .false. +- cnorm = .false. +-c +- if (info .ne. 0) then +-c +-c %--------------------------------------------% +-c | User provides the initial residual vector. | +-c %--------------------------------------------% +-c +- initv = .true. +- info = 0 +- else +- initv = .false. +- end if +- end if +-c +-c %---------------------------------------------% +-c | Get a possibly random starting vector and | +-c | force it into the range of the operator OP. | +-c %---------------------------------------------% +-c +- 10 continue +-c +- if (getv0) then +- call cgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, +- & ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (rnorm .eq. rzero) then +-c +-c %-----------------------------------------% +-c | The initial vector is zero. Error exit. | +-c %-----------------------------------------% +-c +- info = -9 +- go to 1100 +- end if +- getv0 = .false. +- ido = 0 +- end if +-c +-c %-----------------------------------% +-c | Back from reverse communication : | +-c | continue with update step | +-c %-----------------------------------% +-c +- if (update) go to 20 +-c +-c %-------------------------------------------% +-c | Back from computing user specified shifts | +-c %-------------------------------------------% +-c +- if (ushift) go to 50 +-c +-c %-------------------------------------% +-c | Back from computing residual norm | +-c | at the end of the current iteration | +-c %-------------------------------------% +-c +- if (cnorm) go to 100 +-c +-c %----------------------------------------------------------% +-c | Compute the first NEV steps of the Arnoldi factorization | +-c %----------------------------------------------------------% +-c +- call cnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, +- & h, ldh, ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +-c +-c %--------------------------------------------------------------% +-c | | +-c | M A I N ARNOLDI I T E R A T I O N L O O P | +-c | Each iteration implicitly restarts the Arnoldi | +-c | factorization in place. | +-c | | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- iter = iter + 1 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [iter], ndigit, +- & '_naup2: **** Start of major iteration number ****') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c | Adjust NP since NEV might have been updated by last call | +-c | to the shift application routine cnapps. | +-c %-----------------------------------------------------------% +-c +- np = kplusp - nev +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [nev], ndigit, +- & '_naup2: The length of the current Arnoldi factorization') +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: Extend the Arnoldi factorization by') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c %-----------------------------------------------------------% +-c +- ido = 0 +- 20 continue +- update = .true. +-c +- call cnaitr(ido, bmat, n, nev, np, mode, resid, rnorm, +- & v , ldv , h, ldh, ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +- update = .false. +-c +- if (msglvl .gt. 1) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_naup2: Corresponding B-norm of the residual') +- end if +-c +-c %--------------------------------------------------------% +-c | Compute the eigenvalues and corresponding error bounds | +-c | of the current upper Hessenberg matrix. | +-c %--------------------------------------------------------% +-c +- call cneigh (rnorm, kplusp, h, ldh, ritz, bounds, +- & q, ldq, workl, rwork, ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 1200 +- end if +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The wanted part of the spectrum and corresponding | +-c | error bounds are in the last NEV loc. of RITZ, | +-c | and BOUNDS respectively. | +-c %---------------------------------------------------% +-c +- nev = nev0 +- np = np0 +-c +-c %--------------------------------------------------% +-c | Make a copy of Ritz values and the corresponding | +-c | Ritz estimates obtained from cneigh. | +-c %--------------------------------------------------% +-c +- call ccopy(kplusp,ritz,1,workl(kplusp**2+1),1) +- call ccopy(kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The wanted part of the spectrum and corresponding | +-c | bounds are in the last NEV loc. of RITZ | +-c | BOUNDS respectively. | +-c %---------------------------------------------------% +-c +- call cngets (ishift, which, nev, np, ritz, bounds) +-c +-c %------------------------------------------------------------% +-c | Convergence test: currently we use the following criteria. | +-c | The relative accuracy of a Ritz value is considered | +-c | acceptable if: | +-c | | +-c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | +-c | | +-c %------------------------------------------------------------% +-c +- nconv = 0 +-c +- do 25 i = 1, nev +- rtemp = max( eps23, slapy2( real (ritz(np+i)), +- & aimag(ritz(np+i)) ) ) +- if ( slapy2(real (bounds(np+i)),aimag(bounds(np+i))) +- & .le. tol*rtemp ) then +- nconv = nconv + 1 +- end if +- 25 continue +-c +- if (msglvl .gt. 2) then +- kp(1) = nev +- kp(2) = np +- kp(3) = nconv +- call ivout (logfil, 3, kp, ndigit, +- & '_naup2: NEV, NP, NCONV are') +- call cvout (logfil, kplusp, ritz, ndigit, +- & '_naup2: The eigenvalues of H') +- call cvout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Ritz estimates of the current NCV Ritz values') +- end if +-c +-c %---------------------------------------------------------% +-c | Count the number of unwanted Ritz values that have zero | +-c | Ritz estimates. If any Ritz estimates are equal to zero | +-c | then a leading block of H of order equal to at least | +-c | the number of Ritz values with zero Ritz estimates has | +-c | split off. None of these Ritz values may be removed by | +-c | shifting. Decrease NP the number of shifts to apply. If | +-c | no shifts may be applied, then prepare to exit | +-c %---------------------------------------------------------% +-c +- nptemp = np +- do 30 j=1, nptemp +- if (bounds(j) .eq. zero) then +- np = np - 1 +- nev = nev + 1 +- end if +- 30 continue +-c +- if ( (nconv .ge. nev0) .or. +- & (iter .gt. mxiter) .or. +- & (np .eq. 0) ) then +-c +- if (msglvl .gt. 4) then +- call cvout(logfil, kplusp, workl(kplusp**2+1), ndigit, +- & '_naup2: Eigenvalues computed by _neigh:') +- call cvout(logfil, kplusp, workl(kplusp**2+kplusp+1), +- & ndigit, +- & '_naup2: Ritz estimates computed by _neigh:') +- end if +-c +-c %------------------------------------------------% +-c | Prepare to exit. Put the converged Ritz values | +-c | and corresponding bounds in RITZ(1:NCONV) and | +-c | BOUNDS(1:NCONV) respectively. Then sort. Be | +-c | careful when NCONV > NP | +-c %------------------------------------------------% +-c +-c %------------------------------------------% +-c | Use h( 3,1 ) as storage to communicate | +-c | rnorm to cneupd if needed | +-c %------------------------------------------% +- +- h(3,1) = cmplx(rnorm,rzero) +-c +-c %----------------------------------------------% +-c | Sort Ritz values so that converged Ritz | +-c | values appear within the first NEV locations | +-c | of ritz and bounds, and the most desired one | +-c | appears at the front. | +-c %----------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SM' +- if (which .eq. 'SM') wprime = 'LM' +- if (which .eq. 'LR') wprime = 'SR' +- if (which .eq. 'SR') wprime = 'LR' +- if (which .eq. 'LI') wprime = 'SI' +- if (which .eq. 'SI') wprime = 'LI' +-c +- call csortc(wprime, .true., kplusp, ritz, bounds) +-c +-c %--------------------------------------------------% +-c | Scale the Ritz estimate of each Ritz value | +-c | by 1 / max(eps23, magnitude of the Ritz value). | +-c %--------------------------------------------------% +-c +- do 35 j = 1, nev0 +- rtemp = max( eps23, slapy2( real (ritz(j)), +- & aimag(ritz(j)) ) ) +- bounds(j) = bounds(j)/rtemp +- 35 continue +-c +-c %---------------------------------------------------% +-c | Sort the Ritz values according to the scaled Ritz | +-c | estimates. This will push all the converged ones | +-c | towards the front of ritz, bounds (in the case | +-c | when NCONV < NEV.) | +-c %---------------------------------------------------% +-c +- wprime = 'LM' +- call csortc(wprime, .true., nev0, bounds, ritz) +-c +-c %----------------------------------------------% +-c | Scale the Ritz estimate back to its original | +-c | value. | +-c %----------------------------------------------% +-c +- do 40 j = 1, nev0 +- rtemp = max( eps23, slapy2( real (ritz(j)), +- & aimag(ritz(j)) ) ) +- bounds(j) = bounds(j)*rtemp +- 40 continue +-c +-c %-----------------------------------------------% +-c | Sort the converged Ritz values again so that | +-c | the "threshold" value appears at the front of | +-c | ritz and bound. | +-c %-----------------------------------------------% +-c +- call csortc(which, .true., nconv, ritz, bounds) +-c +- if (msglvl .gt. 1) then +- call cvout (logfil, kplusp, ritz, ndigit, +- & '_naup2: Sorted eigenvalues') +- call cvout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Sorted ritz estimates.') +- end if +-c +-c %------------------------------------% +-c | Max iterations have been exceeded. | +-c %------------------------------------% +-c +- if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 +-c +-c %---------------------% +-c | No shifts to apply. | +-c %---------------------% +-c +- if (np .eq. 0 .and. nconv .lt. nev0) info = 2 +-c +- np = nconv +- go to 1100 +-c +- else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then +-c +-c %-------------------------------------------------% +-c | Do not have all the requested eigenvalues yet. | +-c | To prevent possible stagnation, adjust the size | +-c | of NEV. | +-c %-------------------------------------------------% +-c +- nevbef = nev +- nev = nev + min(nconv, np/2) +- if (nev .eq. 1 .and. kplusp .ge. 6) then +- nev = kplusp / 2 +- else if (nev .eq. 1 .and. kplusp .gt. 3) then +- nev = 2 +- end if +- np = kplusp - nev +-c +-c %---------------------------------------% +-c | If the size of NEV was just increased | +-c | resort the eigenvalues. | +-c %---------------------------------------% +-c +- if (nevbef .lt. nev) +- & call cngets (ishift, which, nev, np, ritz, bounds) +-c +- end if +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [nconv], ndigit, +- & '_naup2: no. of "converged" Ritz values at this iter.') +- if (msglvl .gt. 1) then +- kp(1) = nev +- kp(2) = np +- call ivout (logfil, 2, kp, ndigit, +- & '_naup2: NEV and NP are') +- call cvout (logfil, nev, ritz(np+1), ndigit, +- & '_naup2: "wanted" Ritz values ') +- call cvout (logfil, nev, bounds(np+1), ndigit, +- & '_naup2: Ritz estimates of the "wanted" values ') +- end if +- end if +-c +- if (ishift .eq. 0) then +-c +-c %-------------------------------------------------------% +-c | User specified shifts: pop back out to get the shifts | +-c | and return them in the first 2*NP locations of WORKL. | +-c %-------------------------------------------------------% +-c +- ushift = .true. +- ido = 3 +- go to 9000 +- end if +- 50 continue +- ushift = .false. +-c +- if ( ishift .ne. 1 ) then +-c +-c %----------------------------------% +-c | Move the NP shifts from WORKL to | +-c | RITZ, to free up WORKL | +-c | for non-exact shift case. | +-c %----------------------------------% +-c +- call ccopy (np, workl, 1, ritz, 1) +- end if +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: The number of shifts to apply ') +- call cvout (logfil, np, ritz, ndigit, +- & '_naup2: values of the shifts') +- if ( ishift .eq. 1 ) +- & call cvout (logfil, np, bounds, ndigit, +- & '_naup2: Ritz estimates of the shifts') +- end if +-c +-c %---------------------------------------------------------% +-c | Apply the NP implicit shifts by QR bulge chasing. | +-c | Each shift is applied to the whole upper Hessenberg | +-c | matrix H. | +-c | The first 2*N locations of WORKD are used as workspace. | +-c %---------------------------------------------------------% +-c +- call cnapps (n, nev, np, ritz, v, ldv, +- & h, ldh, resid, q, ldq, workl, workd) +-c +-c %---------------------------------------------% +-c | Compute the B-norm of the updated residual. | +-c | Keep B*RESID in WORKD(1:N) to be used in | +-c | the first step of the next call to cnaitr. | +-c %---------------------------------------------% +-c +- cnorm = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call ccopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*RESID | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call ccopy (n, resid, 1, workd, 1) +- end if +-c +- 100 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(1:N) := B*RESID | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- cmpnorm = ccdotc (n, resid, 1, workd, 1) +- rnorm = sqrt(slapy2(real (cmpnorm),aimag(cmpnorm))) +- else if (bmat .eq. 'I') then +- rnorm = scnrm2(n, resid, 1) +- end if +- cnorm = .false. +-c +- if (msglvl .gt. 2) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_naup2: B-norm of residual for compressed factorization') +- call cmout (logfil, nev, nev, h, ldh, ndigit, +- & '_naup2: Compressed upper Hessenberg matrix H') +- end if +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 1100 continue +-c +- mxiter = iter +- nev = nconv +-c +- 1200 continue +- ido = 99 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- call arscnd (t1) +- tcaup2 = t1 - t0 +-c +- 9000 continue +-c +-c %---------------% +-c | End of cnaup2 | +-c %---------------% +-c +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaupd.f +deleted file mode 100644 +index 57be328bf6..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cnaupd.f ++++ /dev/null +@@ -1,664 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cnaupd +-c +-c\Description: +-c Reverse communication interface for the Implicitly Restarted Arnoldi +-c iteration. This is intended to be used to find a few eigenpairs of a +-c complex linear operator OP with respect to a semi-inner product defined +-c by a hermitian positive semi-definite real matrix B. B may be the identity +-c matrix. NOTE: if both OP and B are real, then ssaupd or snaupd should +-c be used. +-c +-c +-c The computed approximate eigenvalues are called Ritz values and +-c the corresponding approximate eigenvectors are called Ritz vectors. +-c +-c cnaupd is usually called iteratively to solve one of the +-c following problems: +-c +-c Mode 1: A*x = lambda*x. +-c ===> OP = A and B = I. +-c +-c Mode 2: A*x = lambda*M*x, M hermitian positive definite +-c ===> OP = inv[M]*A and B = M. +-c ===> (If M can be factored see remark 3 below) +-c +-c Mode 3: A*x = lambda*M*x, M hermitian semi-definite +-c ===> OP = inv[A - sigma*M]*M and B = M. +-c ===> shift-and-invert mode +-c If OP*x = amu*x, then lambda = sigma + 1/amu. +-c +-c +-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +-c should be accomplished either by a direct method +-c using a sparse matrix factorization and solving +-c +-c [A - sigma*M]*w = v or M*w = v, +-c +-c or through an iterative method for solving these +-c systems. If an iterative method is used, the +-c convergence test must be more stringent than +-c the accuracy requirements for the eigenvalue +-c approximations. +-c +-c\Usage: +-c call cnaupd +-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +-c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to cnaupd. IDO will be set internally to +-c indicate the type of operation to be performed. Control is +-c then given back to the calling routine which has the +-c responsibility to carry out the requested operation and call +-c cnaupd with the result. The operand is given in +-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c In mode 3, the vector B * X is already +-c available in WORKD(ipntr(3)). It does not +-c need to be recomputed in forming OP * X. +-c IDO = 2: compute Y = M * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 3: compute and return the shifts in the first +-c NP locations of WORKL. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c After the initialization phase, when the routine is used in +-c the "shift-and-invert" mode, the vector M * X is already +-c available and does not need to be recomputed in forming OP*X. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. +-c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x +-c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c WHICH Character*2. (INPUT) +-c 'LM' -> want the NEV eigenvalues of largest magnitude. +-c 'SM' -> want the NEV eigenvalues of smallest magnitude. +-c 'LR' -> want the NEV eigenvalues of largest real part. +-c 'SR' -> want the NEV eigenvalues of smallest real part. +-c 'LI' -> want the NEV eigenvalues of largest imaginary part. +-c 'SI' -> want the NEV eigenvalues of smallest imaginary part. +-c +-c NEV Integer. (INPUT) +-c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. +-c +-c TOL Real scalar. (INPUT) +-c Stopping criteria: the relative accuracy of the Ritz value +-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) +-c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. +-c DEFAULT = slamch('EPS') (machine precision as computed +-c by the LAPACK auxiliary subroutine slamch). +-c +-c RESID Complex array of length N. (INPUT/OUTPUT) +-c On INPUT: +-c If INFO .EQ. 0, a random initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c On OUTPUT: +-c RESID contains the final residual vector. +-c +-c NCV Integer. (INPUT) +-c Number of columns of the matrix V. NCV must satisfy the two +-c inequalities 1 <= NCV-NEV and NCV <= N. +-c This will indicate how many Arnoldi vectors are generated +-c at each iteration. After the startup phase in which NEV +-c Arnoldi vectors are generated, the algorithm generates +-c approximately NCV-NEV Arnoldi vectors at each subsequent update +-c iteration. Most of the cost in generating each Arnoldi vector is +-c in the matrix-vector operation OP*x. (See remark 4 below.) +-c +-c V Complex array N by NCV. (OUTPUT) +-c Contains the final set of Arnoldi basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling program. +-c +-c IPARAM Integer array of length 11. (INPUT/OUTPUT) +-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +-c The shifts selected at each iteration are used to filter out +-c the components of the unwanted eigenvector. +-c ------------------------------------------------------------- +-c ISHIFT = 0: the shifts are to be provided by the user via +-c reverse communication. The NCV eigenvalues of +-c the Hessenberg matrix H are returned in the part +-c of WORKL array corresponding to RITZ. +-c ISHIFT = 1: exact shifts with respect to the current +-c Hessenberg matrix H. This is equivalent to +-c restarting the iteration from the beginning +-c after updating the starting vector with a linear +-c combination of Ritz vectors associated with the +-c "wanted" eigenvalues. +-c ISHIFT = 2: other choice of internal shift to be defined. +-c ------------------------------------------------------------- +-c +-c IPARAM(2) = No longer referenced +-c +-c IPARAM(3) = MXITER +-c On INPUT: maximum number of Arnoldi update iterations allowed. +-c On OUTPUT: actual number of Arnoldi update iterations taken. +-c +-c IPARAM(4) = NB: blocksize to be used in the recurrence. +-c The code currently works only for NB = 1. +-c +-c IPARAM(5) = NCONV: number of "converged" Ritz values. +-c This represents the number of Ritz values that satisfy +-c the convergence criterion. +-c +-c IPARAM(6) = IUPD +-c No longer referenced. Implicit restarting is ALWAYS used. +-c +-c IPARAM(7) = MODE +-c On INPUT determines what type of eigenproblem is being solved. +-c Must be 1,2,3; See under \Description of cnaupd for the +-c four modes available. +-c +-c IPARAM(8) = NP +-c When ido = 3 and the user provides shifts through reverse +-c communication (IPARAM(1)=0), _naupd returns NP, the number +-c of shifts the user is to provide. 0 < NP < NCV-NEV. +-c +-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +-c OUTPUT: NUMOP = total number of OP*x operations, +-c NUMOPB = total number of B*x operations if BMAT='G', +-c NUMREO = total number of steps of re-orthogonalization. +-c +-c IPNTR Integer array of length 14. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD and WORKL +-c arrays for matrices/vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X in WORKD. +-c IPNTR(2): pointer to the current result vector Y in WORKD. +-c IPNTR(3): pointer to the vector B * X in WORKD when used in +-c the shift-and-invert mode. +-c IPNTR(4): pointer to the next available location in WORKL +-c that is untouched by the program. +-c IPNTR(5): pointer to the NCV by NCV upper Hessenberg +-c matrix H in WORKL. +-c IPNTR(6): pointer to the ritz value array RITZ +-c IPNTR(7): pointer to the (projected) ritz vector array Q +-c IPNTR(8): pointer to the error BOUNDS array in WORKL. +-c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. +-c +-c Note: IPNTR(9:13) is only referenced by cneupd. See Remark 2 below. +-c +-c IPNTR(9): pointer to the NCV RITZ values of the +-c original system. +-c IPNTR(10): Not Used +-c IPNTR(11): pointer to the NCV corresponding error bounds. +-c IPNTR(12): pointer to the NCV by NCV upper triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c cneupd if RVEC = .TRUE. See Remark 2 below. +-c +-c ------------------------------------------------------------- +-c +-c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note below. +-c +-c WORKL Complex work array of length LWORKL. (OUTPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. See Data Distribution Note below. +-c +-c LWORKL Integer. (INPUT) +-c LWORKL must be at least 3*NCV**2 + 5*NCV. +-c +-c RWORK Real work array of length NCV (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal exit. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. IPARAM(5) +-c returns the number of wanted converged Ritz values. +-c = 2: No longer an informational error. Deprecated starting +-c with release 2 of ARPACK. +-c = 3: No shifts could be applied during a cycle of the +-c Implicitly restarted Arnoldi iteration. One possibility +-c is to increase the size of NCV relative to NEV. +-c See remark 4 below. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -4: The maximum number of Arnoldi update iteration +-c must be greater than zero. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work array is not sufficient. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: IPARAM(1) must be equal to 0 or 1. +-c = -9999: Could not build an Arnoldi factorization. +-c User input error highly likely. Please +-c check actual array dimensions and layout. +-c IPARAM(5) returns the size of the current Arnoldi +-c factorization. +-c +-c\Remarks +-c 1. The computed Ritz values are approximate eigenvalues of OP. The +-c selection of WHICH should be made with this in mind when using +-c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will +-c compute the NEV eigenvalues of the original problem that are +-c closest to the shift SIGMA . After convergence, approximate eigenvalues +-c of the original problem may be obtained with the ARPACK subroutine cneupd. +-c +-c 2. If a basis for the invariant subspace corresponding to the converged Ritz +-c values is needed, the user must call cneupd immediately following +-c completion of cnaupd. This is new starting with release 2 of ARPACK. +-c +-c 3. If M can be factored into a Cholesky factorization M = LL` +-c then Mode = 2 should not be selected. Instead one should use +-c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +-c linear systems should be solved with L and L` rather +-c than computing inverses. After convergence, an approximate +-c eigenvector z of the original problem is recovered by solving +-c L`z = x where x is a Ritz vector of OP. +-c +-c 4. At present there is no a-priori analysis to guide the selection +-c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. +-c However, it is recommended that NCV .ge. 2*NEV. If many problems of +-c the same type are to be solved, one should experiment with increasing +-c NCV while keeping NEV fixed for a given test problem. This will +-c usually decrease the required number of OP*x operations but it +-c also increases the work and storage required to maintain the orthogonal +-c basis vectors. The optimal "cross-over" with respect to CPU time +-c is problem dependent and must be determined empirically. +-c See Chapter 8 of Reference 2 for further information. +-c +-c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +-c NP = IPARAM(8) complex shifts in locations +-c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). +-c Eigenvalues of the current upper Hessenberg matrix are located in +-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered +-c according to the order defined by WHICH. The associated Ritz estimates +-c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , +-c WORKL(IPNTR(8)+NCV-1). +-c +-c----------------------------------------------------------------------- +-c +-c\Data Distribution Note: +-c +-c Fortran-D syntax: +-c ================ +-c Complex resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c decompose d1(n), d2(n,ncv) +-c align resid(i) with d1(i) +-c align v(i,j) with d2(i,j) +-c align workd(i) with d1(i) range (1:n) +-c align workd(i) with d1(i-n) range (n+1:2*n) +-c align workd(i) with d1(i-2*n) range (2*n+1:3*n) +-c distribute d1(block), d2(block,:) +-c replicated workl(lworkl) +-c +-c Cray MPP syntax: +-c =============== +-c Complex resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) +-c shared resid(block), v(block,:), workd(block,:) +-c replicated workl(lworkl) +-c +-c CM2/CM5 syntax: +-c ============== +-c +-c----------------------------------------------------------------------- +-c +-c include 'ex-nonsym.doc' +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for +-c _Real_ Matrices", Linear Algebra and its Applications, vol 88/89, +-c pp 575-595, (1987). +-c +-c\Routines called: +-c cnaup2 ARPACK routine that implements the Implicitly Restarted +-c Arnoldi Iteration. +-c cstatn ARPACK routine that initializes the timing variables. +-c ivout ARPACK utility routine that prints integers. +-c cvout ARPACK utility routine that prints vectors. +-c arscnd ARPACK utility routine for timing. +-c slamch LAPACK routine that determines machine constants. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\Remarks +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cnaupd +- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, +- & ipntr, workd, workl, lworkl, rwork, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ldv, lworkl, n, ncv, nev +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- Complex +- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +- Real +- & rwork(ncv) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, levec, mode, msglvl, mxiter, nb, +- & nev0, next, np, ritz, j +- save bounds, ih, iq, ishift, iupd, iw, +- & ldh, ldq, levec, mode, msglvl, mxiter, nb, +- & nev0, next, np, ritz +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external cnaup2, cvout, ivout, arscnd, cstatn +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slamch +- external slamch +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call cstatn +- call arscnd (t0) +- msglvl = mcaupd +-c +-c %----------------% +-c | Error checking | +-c %----------------% +-c +- ierr = 0 +- ishift = iparam(1) +-c levec = iparam(2) +- mxiter = iparam(3) +-c nb = iparam(4) +- nb = 1 +-c +-c %--------------------------------------------% +-c | Revision 2 performs only implicit restart. | +-c %--------------------------------------------% +-c +- iupd = 1 +- mode = iparam(7) +-c +- if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev .or. ncv .gt. n) then +- ierr = -3 +- else if (mxiter .le. 0) then +- ierr = -4 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 5*ncv) then +- ierr = -7 +- else if (mode .lt. 1 .or. mode .gt. 3) then +- ierr = -10 +- else if (mode .eq. 1 .and. bmat .eq. 'G') then +- ierr = -11 +- end if +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- ido = 99 +- go to 9000 +- end if +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- if (nb .le. 0) nb = 1 +- if (tol .le. 0.0E+0 ) tol = slamch('EpsMach') +- if (ishift .ne. 0 .and. +- & ishift .ne. 1 .and. +- & ishift .ne. 2) ishift = 1 +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c | NEV0 is the local variable designating the | +-c | size of the invariant subspace desired. | +-c %----------------------------------------------% +-c +- np = ncv - nev +- nev0 = nev +-c +-c %-----------------------------% +-c | Zero out internal workspace | +-c %-----------------------------% +-c +- do 10 j = 1, 3*ncv**2 + 5*ncv +- workl(j) = zero +- 10 continue +-c +-c %-------------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | +-c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | +-c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | +-c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | +-c | The final workspace is needed by subroutine cneigh called | +-c | by cnaup2. Subroutine cneigh calls LAPACK routines for | +-c | calculating eigenvalues and the last row of the eigenvector | +-c | matrix. | +-c %-------------------------------------------------------------% +-c +- ldh = ncv +- ldq = ncv +- ih = 1 +- ritz = ih + ldh*ncv +- bounds = ritz + ncv +- iq = bounds + ncv +- iw = iq + ldq*ncv +- next = iw + ncv**2 + 3*ncv +-c +- ipntr(4) = next +- ipntr(5) = ih +- ipntr(6) = ritz +- ipntr(7) = iq +- ipntr(8) = bounds +- ipntr(14) = iw +- end if +-c +-c %-------------------------------------------------------% +-c | Carry out the Implicitly restarted Arnoldi Iteration. | +-c %-------------------------------------------------------% +-c +- call cnaup2 +- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), +- & workl(bounds), workl(iq), ldq, workl(iw), +- & ipntr, workd, rwork, info ) +-c +-c %--------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP. | +-c %--------------------------------------------------% +-c +- if (ido .eq. 3) iparam(8) = np +- if (ido .ne. 99) go to 9000 +-c +- iparam(3) = mxiter +- iparam(5) = np +- iparam(9) = nopx +- iparam(10) = nbx +- iparam(11) = nrorth +-c +-c %------------------------------------% +-c | Exit if there was an informational | +-c | error within cnaup2. | +-c %------------------------------------% +-c +- if (info .lt. 0) go to 9000 +- if (info .eq. 2) info = 3 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [mxiter], ndigit, +- & '_naupd: Number of update iterations taken') +- call ivout (logfil, 1, [np], ndigit, +- & '_naupd: Number of wanted "converged" Ritz values') +- call cvout (logfil, np, workl(ritz), ndigit, +- & '_naupd: The final Ritz values') +- call cvout (logfil, np, workl(bounds), ndigit, +- & '_naupd: Associated Ritz estimates') +- end if +-c +- call arscnd (t1) +- tcaupd = t1 - t0 +-c +- if (msglvl .gt. 0) then +-c +-c %--------------------------------------------------------% +-c | Version Number & Version Date are defined in version.h | +-c %--------------------------------------------------------% +-c +- write (6,1000) +- write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, +- & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, +- & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec +- 1000 format (//, +- & 5x, '=============================================',/ +- & 5x, '= Complex implicit Arnoldi update code =',/ +- & 5x, '= Version Number: ', ' 2.3' , 21x, ' =',/ +- & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ +- & 5x, '=============================================',/ +- & 5x, '= Summary of timing statistics =',/ +- & 5x, '=============================================',//) +- 1100 format ( +- & 5x, 'Total number update iterations = ', i5,/ +- & 5x, 'Total number of OP*x operations = ', i5,/ +- & 5x, 'Total number of B*x operations = ', i5,/ +- & 5x, 'Total number of reorthogonalization steps = ', i5,/ +- & 5x, 'Total number of iterative refinement steps = ', i5,/ +- & 5x, 'Total number of restart steps = ', i5,/ +- & 5x, 'Total time in user OP*x operation = ', f12.6,/ +- & 5x, 'Total time in user B*x operation = ', f12.6,/ +- & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ +- & 5x, 'Total time in naup2 routine = ', f12.6,/ +- & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ +- & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ +- & 5x, 'Total time in (re)start vector generation = ', f12.6,/ +- & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ +- & 5x, 'Total time in getting the shifts = ', f12.6,/ +- & 5x, 'Total time in applying the shifts = ', f12.6,/ +- & 5x, 'Total time in convergence testing = ', f12.6,/ +- & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of cnaupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneigh.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneigh.f +deleted file mode 100644 +index 2e2d4d7265..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneigh.f ++++ /dev/null +@@ -1,257 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cneigh +-c +-c\Description: +-c Compute the eigenvalues of the current upper Hessenberg matrix +-c and the corresponding Ritz estimates given the current residual norm. +-c +-c\Usage: +-c call cneigh +-c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) +-c +-c\Arguments +-c RNORM Real scalar. (INPUT) +-c Residual norm corresponding to the current upper Hessenberg +-c matrix H. +-c +-c N Integer. (INPUT) +-c Size of the matrix H. +-c +-c H Complex N by N array. (INPUT) +-c H contains the current upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZ Complex array of length N. (OUTPUT) +-c On output, RITZ(1:N) contains the eigenvalues of H. +-c +-c BOUNDS Complex array of length N. (OUTPUT) +-c On output, BOUNDS contains the Ritz estimates associated with +-c the eigenvalues held in RITZ. This is equal to RNORM +-c times the last components of the eigenvectors corresponding +-c to the eigenvalues in RITZ. +-c +-c Q Complex N by N array. (WORKSPACE) +-c Workspace needed to store the eigenvectors of H. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Complex work array of length N**2 + 3*N. (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. This is needed to keep the full Schur form +-c of H and also in the calculation of the eigenvectors of H. +-c +-c RWORK Real work array of length N (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c IERR Integer. (OUTPUT) +-c Error exit flag from clahqr or ctrevc. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c cmout ARPACK utility routine that prints matrices +-c cvout ARPACK utility routine that prints vectors. +-c svout ARPACK utility routine that prints vectors. +-c clacpy LAPACK matrix copy routine. +-c clahqr LAPACK routine to compute the Schur form of an +-c upper Hessenberg matrix. +-c claset LAPACK matrix initialization routine. +-c ctrevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper triangular form +-c ccopy Level 1 BLAS that copies one vector to another. +-c csscal Level 1 BLAS that scales a complex vector by a real number. +-c scnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cneigh (rnorm, n, h, ldh, ritz, bounds, +- & q, ldq, workl, rwork, ierr) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer ierr, n, ldh, ldq +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex +- & bounds(n), h(ldh,n), q(ldq,n), ritz(n), +- & workl(n*(n+3)) +- Real +- & rwork(n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- Real +- & rone +- parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), +- & rone = 1.0E+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical select(1) +- integer j, msglvl +- Complex +- & vl(1) +- Real +- & temp +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external clacpy, clahqr, ctrevc, ccopy, +- & csscal, cmout, cvout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & scnrm2 +- external scnrm2 +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mceigh +-c +- if (msglvl .gt. 2) then +- call cmout (logfil, n, n, h, ldh, ndigit, +- & '_neigh: Entering upper Hessenberg matrix H ') +- end if +-c +-c %----------------------------------------------------------% +-c | 1. Compute the eigenvalues, the last components of the | +-c | corresponding Schur vectors and the full Schur form T | +-c | of the current upper Hessenberg matrix H. | +-c | clahqr returns the full Schur form of H | +-c | in WORKL(1:N**2), and the Schur vectors in q. | +-c %----------------------------------------------------------% +-c +- call clacpy ('All', n, n, h, ldh, workl, n) +- call claset ('All', n, n, zero, one, q, ldq) +- call clahqr (.true., .true., n, 1, n, workl, ldh, ritz, +- & 1, n, q, ldq, ierr) +- if (ierr .ne. 0) go to 9000 +-c +- call ccopy (n, q(n-1,1), ldq, bounds, 1) +- if (msglvl .gt. 1) then +- call cvout (logfil, n, bounds, ndigit, +- & '_neigh: last row of the Schur matrix for H') +- end if +-c +-c %----------------------------------------------------------% +-c | 2. Compute the eigenvectors of the full Schur form T and | +-c | apply the Schur vectors to get the corresponding | +-c | eigenvectors. | +-c %----------------------------------------------------------% +-c +- call ctrevc ('Right', 'Back', select, n, workl, n, vl, n, q, +- & ldq, n, n, workl(n*n+1), rwork, ierr) +-c +- if (ierr .ne. 0) go to 9000 +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | Euclidean norms are all one. LAPACK subroutine | +-c | ctrevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1; here the magnitude of a complex | +-c | number (x,y) is taken to be |x| + |y|. | +-c %------------------------------------------------% +-c +- do 10 j=1, n +- temp = scnrm2( n, q(1,j), 1 ) +- call csscal ( n, rone / temp, q(1,j), 1 ) +- 10 continue +-c +- if (msglvl .gt. 1) then +- call ccopy(n, q(n,1), ldq, workl, 1) +- call cvout (logfil, n, workl, ndigit, +- & '_neigh: Last row of the eigenvector matrix for H') +- end if +-c +-c %----------------------------% +-c | Compute the Ritz estimates | +-c %----------------------------% +-c +- call ccopy(n, q(n,1), n, bounds, 1) +- call csscal(n, rnorm, bounds, 1) +-c +- if (msglvl .gt. 2) then +- call cvout (logfil, n, ritz, ndigit, +- & '_neigh: The eigenvalues of H') +- call cvout (logfil, n, bounds, ndigit, +- & '_neigh: Ritz estimates for the eigenvalues of H') +- end if +-c +- call arscnd(t1) +- tceigh = tceigh + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of cneigh | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneupd.f +deleted file mode 100644 +index 29154ce37e..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cneupd.f ++++ /dev/null +@@ -1,876 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cneupd +-c +-c\Description: +-c This subroutine returns the converged approximations to eigenvalues +-c of A*z = lambda*B*z and (optionally): +-c +-c (1) The corresponding approximate eigenvectors; +-c +-c (2) An orthonormal basis for the associated approximate +-c invariant subspace; +-c +-c (3) Both. +-c +-c There is negligible additional cost to obtain eigenvectors. An orthonormal +-c basis is always computed. There is an additional storage cost of n*nev +-c if both are requested (in this case a separate array Z must be supplied). +-c +-c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z +-c are derived from approximate eigenvalues and eigenvectors of +-c of the linear operator OP prescribed by the MODE selection in the +-c call to CNAUPD. CNAUPD must be called before this routine is called. +-c These approximate eigenvalues and vectors are commonly called Ritz +-c values and Ritz vectors respectively. They are referred to as such +-c in the comments that follow. The computed orthonormal basis for the +-c invariant subspace corresponding to these Ritz values is referred to as a +-c Schur basis. +-c +-c The definition of OP as well as other terms and the relation of computed +-c Ritz values and vectors of OP with respect to the given problem +-c A*z = lambda*B*z may be found in the header of CNAUPD. For a brief +-c description, see definitions of IPARAM(7), MODE and WHICH in the +-c documentation of CNAUPD. +-c +-c\Usage: +-c call cneupd +-c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, +-c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, +-c WORKL, LWORKL, RWORK, INFO ) +-c +-c\Arguments: +-c RVEC LOGICAL (INPUT) +-c Specifies whether a basis for the invariant subspace corresponding +-c to the converged Ritz value approximations for the eigenproblem +-c A*z = lambda*B*z is computed. +-c +-c RVEC = .FALSE. Compute Ritz values only. +-c +-c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. +-c See Remarks below. +-c +-c HOWMNY Character*1 (INPUT) +-c Specifies the form of the basis for the invariant subspace +-c corresponding to the converged Ritz values that is to be computed. +-c +-c = 'A': Compute NEV Ritz vectors; +-c = 'P': Compute NEV Schur vectors; +-c = 'S': compute some of the Ritz vectors, specified +-c by the logical array SELECT. +-c +-c SELECT Logical array of dimension NCV. (INPUT) +-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +-c computed. To select the Ritz vector corresponding to a +-c Ritz value D(j), SELECT(j) must be set to .TRUE.. +-c If HOWMNY = 'A' or 'P', SELECT need not be initialized +-c but it is used as internal workspace. +-c +-c D Complex array of dimension NEV+1. (OUTPUT) +-c On exit, D contains the Ritz approximations +-c to the eigenvalues lambda for A*z = lambda*B*z. +-c +-c Z Complex N by NEV array (OUTPUT) +-c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of +-c Z represents approximate eigenvectors (Ritz vectors) corresponding +-c to the NCONV=IPARAM(5) Ritz values for eigensystem +-c A*z = lambda*B*z. +-c +-c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. +-c +-c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, +-c the array Z may be set equal to first NEV+1 columns of the Arnoldi +-c basis array V computed by CNAUPD. In this case the Arnoldi basis +-c will be destroyed and overwritten with the eigenvector basis. +-c +-c LDZ Integer. (INPUT) +-c The leading dimension of the array Z. If Ritz vectors are +-c desired, then LDZ .ge. max( 1, N ) is required. +-c In any case, LDZ .ge. 1 is required. +-c +-c SIGMA Complex (INPUT) +-c If IPARAM(7) = 3 then SIGMA represents the shift. +-c Not referenced if IPARAM(7) = 1 or 2. +-c +-c WORKEV Complex work array of dimension 2*NCV. (WORKSPACE) +-c +-c **** The remaining arguments MUST be the same as for the **** +-c **** call to CNAUPD that was just completed. **** +-c +-c NOTE: The remaining arguments +-c +-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +-c WORKD, WORKL, LWORKL, RWORK, INFO +-c +-c must be passed directly to CNEUPD following the last call +-c to CNAUPD. These arguments MUST NOT BE MODIFIED between +-c the the last call to CNAUPD and the call to CNEUPD. +-c +-c Three of these parameters (V, WORKL and INFO) are also output parameters: +-c +-c V Complex N by NCV array. (INPUT/OUTPUT) +-c +-c Upon INPUT: the NCV columns of V contain the Arnoldi basis +-c vectors for OP as constructed by CNAUPD . +-c +-c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns +-c contain approximate Schur vectors that span the +-c desired invariant subspace. +-c +-c NOTE: If the array Z has been set equal to first NEV+1 columns +-c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the +-c Arnoldi basis held by V has been overwritten by the desired +-c Ritz vectors. If a separate array Z has been passed then +-c the first NCONV=IPARAM(5) columns of V will contain approximate +-c Schur vectors that span the desired invariant subspace. +-c +-c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) +-c WORKL(1:ncv*ncv+2*ncv) contains information obtained in +-c cnaupd. They are not changed by cneupd. +-c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the +-c untransformed Ritz values, the untransformed error estimates of +-c the Ritz values, the upper triangular matrix for H, and the +-c associated matrix representation of the invariant subspace for H. +-c +-c Note: IPNTR(9:13) contains the pointer into WORKL for addresses +-c of the above information computed by cneupd. +-c ------------------------------------------------------------- +-c IPNTR(9): pointer to the NCV RITZ values of the +-c original system. +-c IPNTR(10): Not used +-c IPNTR(11): pointer to the NCV corresponding error estimates. +-c IPNTR(12): pointer to the NCV by NCV upper triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c cneupd if RVEC = .TRUE. See Remark 2 below. +-c ------------------------------------------------------------- +-c +-c INFO Integer. (OUTPUT) +-c Error flag on output. +-c = 0: Normal exit. +-c +-c = 1: The Schur form computed by LAPACK routine csheqr +-c could not be reordered by LAPACK routine ctrsen. +-c Re-enter subroutine cneupd with IPARAM(5)=NCV and +-c increase the size of the array D to have +-c dimension at least dimension NCV and allocate at least NCV +-c columns for Z. NOTE: Not necessary if Z and V share +-c the same space. Please notify the authors if this error +-c occurs. +-c +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work WORKL array is not sufficient. +-c = -8: Error return from LAPACK eigenvalue calculation. +-c This should never happened. +-c = -9: Error return from calculation of eigenvectors. +-c Informational error from LAPACK routine ctrevc. +-c = -10: IPARAM(7) must be 1,2,3 +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: HOWMNY = 'S' not yet implemented +-c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. +-c = -14: CNAUPD did not find any eigenvalues to sufficient +-c accuracy. +-c = -15: CNEUPD got a different count of the number of converged +-c Ritz values than CNAUPD got. This indicates the user +-c probably made an error in passing data from CNAUPD to +-c CNEUPD or that the data was modified before entering +-c CNEUPD +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, +-c "How to Implement the Spectral Transformation", Math Comp., +-c Vol. 48, No. 178, April, 1987 pp. 664-673. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c cmout ARPACK utility routine that prints matrices +-c cvout ARPACK utility routine that prints vectors. +-c cgeqr2 LAPACK routine that computes the QR factorization of +-c a matrix. +-c clacpy LAPACK matrix copy routine. +-c clahqr LAPACK routine that computes the Schur form of a +-c upper Hessenberg matrix. +-c claset LAPACK matrix initialization routine. +-c ctrevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper triangular form. +-c ctrsen LAPACK routine that re-orders the Schur form. +-c cunm2r LAPACK routine that applies an orthogonal matrix in +-c factored form. +-c slamch LAPACK routine that determines machine constants. +-c ctrmm Level 3 BLAS matrix times an upper triangular matrix. +-c cgeru Level 2 BLAS rank one update to a matrix. +-c ccopy Level 1 BLAS that copies one vector to another . +-c cscal Level 1 BLAS that scales a vector. +-c csscal Level 1 BLAS that scales a complex vector by a real number. +-c scnrm2 Level 1 BLAS that computes the norm of a complex vector. +-c +-c\Remarks +-c +-c 1. Currently only HOWMNY = 'A' and 'P' are implemented. +-c +-c 2. Schur vectors are an orthogonal representation for the basis of +-c Ritz vectors. Thus, their numerical properties are often superior. +-c If RVEC = .true. then the relationship +-c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and +-c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I +-c are approximately satisfied. +-c Here T is the leading submatrix of order IPARAM(5) of the +-c upper triangular matrix stored workl(ipntr(12)). +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +- subroutine cneupd(rvec , howmny, select, d , +- & z , ldz , sigma , workev, +- & bmat , n , which , nev , +- & tol , resid , ncv , v , +- & ldv , iparam, ipntr , workd , +- & workl, lworkl, rwork , info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat, howmny, which*2 +- logical rvec +- integer info, ldz, ldv, lworkl, n, ncv, nev +- Complex +- & sigma +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- logical select(ncv) +- Real +- & rwork(ncv) +- Complex +- & d(nev) , resid(n) , v(ldv,ncv), +- & z(ldz, nev), +- & workd(3*n) , workl(lworkl), workev(2*ncv) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character type*6 +- integer bounds, ierr , ih , ihbds, iheig , nconv , +- & invsub, iuptri, iwev , j , ldh , ldq , +- & mode , msglvl, ritz , wr , k , irz , +- & ibd , outncv, iq , np , numcnv, jj , +- & ishift, nconv2 +- Complex +- & rnorm, temp, vl(1) +- Real +- & conds, sep, rtemp, eps23 +- logical reord +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external ccopy , cgeru, cgeqr2, clacpy, cmout, +- & cunm2r, ctrmm, cvout, ivout, +- & clahqr +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & scnrm2, slamch, slapy2 +- external scnrm2, slamch, slapy2 +-c +- Complex +- & ccdotc +- external ccdotc +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- msglvl = mceupd +- mode = iparam(7) +- nconv = iparam(5) +- info = 0 +-c +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0) +-c +-c %-------------------------------% +-c | Quick return | +-c | Check for incompatible input | +-c %-------------------------------% +-c +- ierr = 0 +-c +- if (nconv .le. 0) then +- ierr = -14 +- else if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev+1 .or. ncv .gt. n) then +- ierr = -3 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 4*ncv) then +- ierr = -7 +- else if ( (howmny .ne. 'A' .and. +- & howmny .ne. 'P' .and. +- & howmny .ne. 'S') .and. rvec ) then +- ierr = -13 +- else if (howmny .eq. 'S' ) then +- ierr = -12 +- end if +-c +- if (mode .eq. 1 .or. mode .eq. 2) then +- type = 'REGULR' +- else if (mode .eq. 3 ) then +- type = 'SHIFTI' +- else +- ierr = -10 +- end if +- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | +-c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | +-c %--------------------------------------------------------% +-c +-c %-----------------------------------------------------------% +-c | The following is used and set by CNEUPD. | +-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | +-c | Ritz values. | +-c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | +-c | error bounds of | +-c | the Ritz values | +-c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | +-c | triangular matrix | +-c | for H. | +-c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | +-c | associated matrix | +-c | representation of | +-c | the invariant | +-c | subspace for H. | +-c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | +-c %-----------------------------------------------------------% +-c +- ih = ipntr(5) +- ritz = ipntr(6) +- iq = ipntr(7) +- bounds = ipntr(8) +- ldh = ncv +- ldq = ncv +- iheig = bounds + ldh +- ihbds = iheig + ldh +- iuptri = ihbds + ldh +- invsub = iuptri + ldh*ncv +- ipntr(9) = iheig +- ipntr(11) = ihbds +- ipntr(12) = iuptri +- ipntr(13) = invsub +- wr = 1 +- iwev = wr + ncv +-c +-c %-----------------------------------------% +-c | irz points to the Ritz values computed | +-c | by _neigh before exiting _naup2. | +-c | ibd points to the Ritz estimates | +-c | computed by _neigh before exiting | +-c | _naup2. | +-c %-----------------------------------------% +-c +- irz = ipntr(14) + ncv*ncv +- ibd = irz + ncv +-c +-c %------------------------------------% +-c | RNORM is B-norm of the RESID(1:N). | +-c %------------------------------------% +-c +- rnorm = workl(ih+2) +- workl(ih+2) = zero +-c +- if (msglvl .gt. 2) then +- call cvout(logfil, ncv, workl(irz), ndigit, +- & '_neupd: Ritz values passed in from _NAUPD.') +- call cvout(logfil, ncv, workl(ibd), ndigit, +- & '_neupd: Ritz estimates passed in from _NAUPD.') +- end if +-c +- if (rvec) then +-c +- reord = .false. +-c +-c %---------------------------------------------------% +-c | Use the temporary bounds array to store indices | +-c | These will be used to mark the select array later | +-c %---------------------------------------------------% +-c +- do 10 j = 1,ncv +- workl(bounds+j-1) = j +- select(j) = .false. +- 10 continue +-c +-c %-------------------------------------% +-c | Select the wanted Ritz values. | +-c | Sort the Ritz values so that the | +-c | wanted ones appear at the tailing | +-c | NEV positions of workl(irr) and | +-c | workl(iri). Move the corresponding | +-c | error estimates in workl(ibd) | +-c | accordingly. | +-c %-------------------------------------% +-c +- np = ncv - nev +- ishift = 0 +- call cngets(ishift, which , nev , +- & np , workl(irz), workl(bounds)) +-c +- if (msglvl .gt. 2) then +- call cvout (logfil, ncv, workl(irz), ndigit, +- & '_neupd: Ritz values after calling _NGETS.') +- call cvout (logfil, ncv, workl(bounds), ndigit, +- & '_neupd: Ritz value indices after calling _NGETS.') +- end if +-c +-c %-----------------------------------------------------% +-c | Record indices of the converged wanted Ritz values | +-c | Mark the select array for possible reordering | +-c %-----------------------------------------------------% +-c +- numcnv = 0 +- do 11 j = 1,ncv +- rtemp = max(eps23, +- & slapy2 ( real(workl(irz+ncv-j)), +- & aimag(workl(irz+ncv-j)) )) +- jj = workl(bounds + ncv - j) +- if (numcnv .lt. nconv .and. +- & slapy2( real(workl(ibd+jj-1)), +- & aimag(workl(ibd+jj-1)) ) +- & .le. tol*rtemp) then +- select(jj) = .true. +- numcnv = numcnv + 1 +- if (jj .gt. nconv) reord = .true. +- endif +- 11 continue +-c +-c %-----------------------------------------------------------% +-c | Check the count (numcnv) of converged Ritz values with | +-c | the number (nconv) reported by dnaupd. If these two | +-c | are different then there has probably been an error | +-c | caused by incorrect passing of the dnaupd data. | +-c %-----------------------------------------------------------% +-c +- if (msglvl .gt. 2) then +- call ivout(logfil, 1, [numcnv], ndigit, +- & '_neupd: Number of specified eigenvalues') +- call ivout(logfil, 1, [nconv], ndigit, +- & '_neupd: Number of "converged" eigenvalues') +- end if +-c +- if (numcnv .ne. nconv) then +- info = -15 +- go to 9000 +- end if +-c +-c %-------------------------------------------------------% +-c | Call LAPACK routine clahqr to compute the Schur form | +-c | of the upper Hessenberg matrix returned by CNAUPD. | +-c | Make a copy of the upper Hessenberg matrix. | +-c | Initialize the Schur vector matrix Q to the identity. | +-c %-------------------------------------------------------% +-c +- call ccopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) +- call claset('All', ncv, ncv , +- & zero , one, workl(invsub), +- & ldq) +- call clahqr(.true., .true. , ncv , +- & 1 , ncv , workl(iuptri), +- & ldh , workl(iheig) , 1 , +- & ncv , workl(invsub), ldq , +- & ierr) +- call ccopy(ncv , workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 9000 +- end if +-c +- if (msglvl .gt. 1) then +- call cvout (logfil, ncv, workl(iheig), ndigit, +- & '_neupd: Eigenvalues of H') +- call cvout (logfil, ncv, workl(ihbds), ndigit, +- & '_neupd: Last row of the Schur vector matrix') +- if (msglvl .gt. 3) then +- call cmout (logfil , ncv, ncv , +- & workl(iuptri), ldh, ndigit, +- & '_neupd: The upper triangular matrix ') +- end if +- end if +-c +- if (reord) then +-c +-c %-----------------------------------------------% +-c | Reorder the computed upper triangular matrix. | +-c %-----------------------------------------------% +-c +- call ctrsen('None' , 'V' , select , +- & ncv , workl(iuptri), ldh , +- & workl(invsub), ldq , workl(iheig), +- & nconv2 , conds , sep , +- & workev , ncv , ierr) +-c +- if (nconv2 .lt. nconv) then +- nconv = nconv2 +- end if +- +- if (ierr .eq. 1) then +- info = 1 +- go to 9000 +- end if +-c +- if (msglvl .gt. 2) then +- call cvout (logfil, ncv, workl(iheig), ndigit, +- & '_neupd: Eigenvalues of H--reordered') +- if (msglvl .gt. 3) then +- call cmout(logfil , ncv, ncv , +- & workl(iuptri), ldq, ndigit, +- & '_neupd: Triangular matrix after re-ordering') +- end if +- end if +-c +- end if +-c +-c %---------------------------------------------% +-c | Copy the last row of the Schur basis matrix | +-c | to workl(ihbds). This vector will be used | +-c | to compute the Ritz estimates of converged | +-c | Ritz values. | +-c %---------------------------------------------% +-c +- call ccopy(ncv , workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +-c +-c %--------------------------------------------% +-c | Place the computed eigenvalues of H into D | +-c | if a spectral transformation was not used. | +-c %--------------------------------------------% +-c +- if (type .eq. 'REGULR') then +- call ccopy(nconv, workl(iheig), 1, d, 1) +- end if +-c +-c %----------------------------------------------------------% +-c | Compute the QR factorization of the matrix representing | +-c | the wanted invariant subspace located in the first NCONV | +-c | columns of workl(invsub,ldq). | +-c %----------------------------------------------------------% +-c +- call cgeqr2(ncv , nconv , workl(invsub), +- & ldq , workev, workev(ncv+1), +- & ierr) +-c +-c %--------------------------------------------------------% +-c | * Postmultiply V by Q using cunm2r. | +-c | * Copy the first NCONV columns of VQ into Z. | +-c | * Postmultiply Z by R. | +-c | The N by NCONV matrix Z is now a matrix representation | +-c | of the approximate invariant subspace associated with | +-c | the Ritz values in workl(iheig). The first NCONV | +-c | columns of V are now approximate Schur vectors | +-c | associated with the upper triangular matrix of order | +-c | NCONV in workl(iuptri). | +-c %--------------------------------------------------------% +-c +- call cunm2r('Right', 'Notranspose', n , +- & ncv , nconv , workl(invsub), +- & ldq , workev , v , +- & ldv , workd(n+1) , ierr) +- call clacpy('All', n, nconv, v, ldv, z, ldz) +-c +- do 20 j=1, nconv +-c +-c %---------------------------------------------------% +-c | Perform both a column and row scaling if the | +-c | diagonal element of workl(invsub,ldq) is negative | +-c | I'm lazy and don't take advantage of the upper | +-c | triangular form of workl(iuptri,ldq). | +-c | Note that since Q is orthogonal, R is a diagonal | +-c | matrix consisting of plus or minus ones. | +-c %---------------------------------------------------% +-c +- if ( real( workl(invsub+(j-1)*ldq+j-1) ) .lt. +- & real(zero) ) then +- call cscal(nconv, -one, workl(iuptri+j-1), ldq) +- call cscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) +- end if +-c +- 20 continue +-c +- if (howmny .eq. 'A') then +-c +-c %--------------------------------------------% +-c | Compute the NCONV wanted eigenvectors of T | +-c | located in workl(iuptri,ldq). | +-c %--------------------------------------------% +-c +- do 30 j=1, ncv +- if (j .le. nconv) then +- select(j) = .true. +- else +- select(j) = .false. +- end if +- 30 continue +-c +- call ctrevc('Right', 'Select' , select , +- & ncv , workl(iuptri), ldq , +- & vl , 1 , workl(invsub), +- & ldq , ncv , outncv , +- & workev , rwork , ierr) +-c +- if (ierr .ne. 0) then +- info = -9 +- go to 9000 +- end if +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | Euclidean norms are all one. LAPACK subroutine | +-c | ctrevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1. | +-c %------------------------------------------------% +-c +- do 40 j=1, nconv +- rtemp = scnrm2(ncv, workl(invsub+(j-1)*ldq), 1) +- rtemp = real(one) / rtemp +- call csscal ( ncv, rtemp, +- & workl(invsub+(j-1)*ldq), 1 ) +-c +-c %------------------------------------------% +-c | Ritz estimates can be obtained by taking | +-c | the inner product of the last row of the | +-c | Schur basis of H with eigenvectors of T. | +-c | Note that the eigenvector matrix of T is | +-c | upper triangular, thus the length of the | +-c | inner product can be set to j. | +-c %------------------------------------------% +-c +- workev(j) = ccdotc(j, workl(ihbds), 1, +- & workl(invsub+(j-1)*ldq), 1) +- 40 continue +-c +- if (msglvl .gt. 2) then +- call ccopy(nconv, workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +- call cvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Last row of the eigenvector matrix for T') +- if (msglvl .gt. 3) then +- call cmout(logfil , ncv, ncv , +- & workl(invsub), ldq, ndigit, +- & '_neupd: The eigenvector matrix for T') +- end if +- end if +-c +-c %---------------------------------------% +-c | Copy Ritz estimates into workl(ihbds) | +-c %---------------------------------------% +-c +- call ccopy(nconv, workev, 1, workl(ihbds), 1) +-c +-c %----------------------------------------------% +-c | The eigenvector matrix Q of T is triangular. | +-c | Form Z*Q. | +-c %----------------------------------------------% +-c +- call ctrmm('Right' , 'Upper' , 'No transpose', +- & 'Non-unit', n , nconv , +- & one , workl(invsub), ldq , +- & z , ldz) +- end if +-c +- else +-c +-c %--------------------------------------------------% +-c | An approximate invariant subspace is not needed. | +-c | Place the Ritz values computed CNAUPD into D. | +-c %--------------------------------------------------% +-c +- call ccopy(nconv, workl(ritz), 1, d, 1) +- call ccopy(nconv, workl(ritz), 1, workl(iheig), 1) +- call ccopy(nconv, workl(bounds), 1, workl(ihbds), 1) +-c +- end if +-c +-c %------------------------------------------------% +-c | Transform the Ritz values and possibly vectors | +-c | and corresponding error bounds of OP to those | +-c | of A*x = lambda*B*x. | +-c %------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +-c +- if (rvec) +- & call cscal(ncv, rnorm, workl(ihbds), 1) +-c +- else +-c +-c %---------------------------------------% +-c | A spectral transformation was used. | +-c | * Determine the Ritz estimates of the | +-c | Ritz values in the original system. | +-c %---------------------------------------% +-c +- if (rvec) +- & call cscal(ncv, rnorm, workl(ihbds), 1) +-c +- do 50 k=1, ncv +- temp = workl(iheig+k-1) +- workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp +- 50 continue +-c +- end if +-c +-c %-----------------------------------------------------------% +-c | * Transform the Ritz values back to the original system. | +-c | For TYPE = 'SHIFTI' the transformation is | +-c | lambda = 1/theta + sigma | +-c | NOTES: | +-c | *The Ritz vectors are not affected by the transformation. | +-c %-----------------------------------------------------------% +-c +- if (type .eq. 'SHIFTI') then +- do 60 k=1, nconv +- d(k) = one / workl(iheig+k-1) + sigma +- 60 continue +- end if +-c +- if (type .ne. 'REGULR' .and. msglvl .gt. 1) then +- call cvout (logfil, nconv, d, ndigit, +- & '_neupd: Untransformed Ritz values.') +- call cvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Ritz estimates of the untransformed Ritz values.') +- else if ( msglvl .gt. 1) then +- call cvout (logfil, nconv, d, ndigit, +- & '_neupd: Converged Ritz values.') +- call cvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Associated Ritz estimates.') +- end if +-c +-c %-------------------------------------------------% +-c | Eigenvector Purification step. Formally perform | +-c | one of inverse subspace iteration. Only used | +-c | for MODE = 3. See reference 3. | +-c %-------------------------------------------------% +-c +- if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then +-c +-c %------------------------------------------------% +-c | Purify the computed Ritz vectors by adding a | +-c | little bit of the residual vector: | +-c | T | +-c | resid(:)*( e s ) / theta | +-c | NCV | +-c | where H s = s theta. | +-c %------------------------------------------------% +-c +- do 100 j=1, nconv +- if (workl(iheig+j-1) .ne. zero) then +- workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / +- & workl(iheig+j-1) +- endif +- 100 continue +- +-c %---------------------------------------% +-c | Perform a rank one update to Z and | +-c | purify all the Ritz vectors together. | +-c %---------------------------------------% +-c +- call cgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) +-c +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of cneupd| +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cngets.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cngets.f +deleted file mode 100644 +index 20626a2d50..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cngets.f ++++ /dev/null +@@ -1,178 +0,0 @@ +-c\BeginDoc +-c +-c\Name: cngets +-c +-c\Description: +-c Given the eigenvalues of the upper Hessenberg matrix H, +-c computes the NP shifts AMU that are zeros of the polynomial of +-c degree NP which filters out components of the unwanted eigenvectors +-c corresponding to the AMU's based on some given criteria. +-c +-c NOTE: call this even in the case of user specified shifts in order +-c to sort the eigenvalues, and error bounds of H for later use. +-c +-c\Usage: +-c call cngets +-c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) +-c +-c\Arguments +-c ISHIFT Integer. (INPUT) +-c Method for selecting the implicit shifts at each iteration. +-c ISHIFT = 0: user specified shifts +-c ISHIFT = 1: exact shift with respect to the matrix H. +-c +-c WHICH Character*2. (INPUT) +-c Shift selection criteria. +-c 'LM' -> want the KEV eigenvalues of largest magnitude. +-c 'SM' -> want the KEV eigenvalues of smallest magnitude. +-c 'LR' -> want the KEV eigenvalues of largest REAL part. +-c 'SR' -> want the KEV eigenvalues of smallest REAL part. +-c 'LI' -> want the KEV eigenvalues of largest imaginary part. +-c 'SI' -> want the KEV eigenvalues of smallest imaginary part. +-c +-c KEV Integer. (INPUT) +-c The number of desired eigenvalues. +-c +-c NP Integer. (INPUT) +-c The number of shifts to compute. +-c +-c RITZ Complex array of length KEV+NP. (INPUT/OUTPUT) +-c On INPUT, RITZ contains the the eigenvalues of H. +-c On OUTPUT, RITZ are sorted so that the unwanted +-c eigenvalues are in the first NP locations and the wanted +-c portion is in the last KEV locations. When exact shifts are +-c selected, the unwanted part corresponds to the shifts to +-c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues +-c are further sorted so that the ones with largest Ritz values +-c are first. +-c +-c BOUNDS Complex array of length KEV+NP. (INPUT/OUTPUT) +-c Error bounds corresponding to the ordering in RITZ. +-c +-c +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex +-c +-c\Routines called: +-c csortc ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c cvout ARPACK utility routine that prints vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c 1. This routine does not keep complex conjugate pairs of +-c eigenvalues together. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine cngets ( ishift, which, kev, np, ritz, bounds) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- integer ishift, kev, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex +- & bounds(kev+np), ritz(kev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex +- & one, zero +- parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external cvout, csortc, arscnd +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mcgets +-c +- call csortc (which, .true., kev+np, ritz, bounds) +-c +- if ( ishift .eq. 1 ) then +-c +-c %-------------------------------------------------------% +-c | Sort the unwanted Ritz values used as shifts so that | +-c | the ones with largest Ritz estimates are first | +-c | This will tend to minimize the effects of the | +-c | forward instability of the iteration when the shifts | +-c | are applied in subroutine cnapps. | +-c | Be careful and use 'SM' since we want to sort BOUNDS! | +-c %-------------------------------------------------------% +-c +- call csortc ( 'SM', .true., np, bounds, ritz ) +-c +- end if +-c +- call arscnd (t1) +- tcgets = tcgets + (t1 - t0) +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [kev], ndigit, '_ngets: KEV is') +- call ivout (logfil, 1, [np], ndigit, '_ngets: NP is') +- call cvout (logfil, kev+np, ritz, ndigit, +- & '_ngets: Eigenvalues of current H matrix ') +- call cvout (logfil, kev+np, bounds, ndigit, +- & '_ngets: Ritz estimates of the current KEV+NP Ritz values') +- end if +-c +- return +-c +-c %---------------% +-c | End of cngets | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/csortc.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/csortc.f +deleted file mode 100644 +index a02bd3ffad..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/csortc.f ++++ /dev/null +@@ -1,322 +0,0 @@ +-c\BeginDoc +-c +-c\Name: csortc +-c +-c\Description: +-c Sorts the Complex array in X into the order +-c specified by WHICH and optionally applies the permutation to the +-c Real array Y. +-c +-c\Usage: +-c call csortc +-c ( WHICH, APPLY, N, X, Y ) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> sort X into increasing order of magnitude. +-c 'SM' -> sort X into decreasing order of magnitude. +-c 'LR' -> sort X with real(X) in increasing algebraic order +-c 'SR' -> sort X with real(X) in decreasing algebraic order +-c 'LI' -> sort X with imag(X) in increasing algebraic order +-c 'SI' -> sort X with imag(X) in decreasing algebraic order +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to array Y. +-c APPLY = .FALSE. -> do not apply the sorted order to array Y. +-c +-c N Integer. (INPUT) +-c Size of the arrays. +-c +-c X Complex array of length N. (INPUT/OUTPUT) +-c This is the array to be sorted. +-c +-c Y Complex array of length N. (INPUT/OUTPUT) +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Routines called: +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c Adapted from the sort routine in LANSO. +-c +-c\SCCS Information: @(#) +-c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine csortc (which, apply, n, x, y) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex +- & x(0:n-1), y(0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Complex +- & temp +- Real +- & temp1, temp2 +-c +-c %--------------------% +-c | External functions | +-c %--------------------% +-c +- Real +- & slapy2 +-c +-c %--------------------% +-c | Intrinsic Functions | +-c %--------------------% +- Intrinsic +- & real, aimag +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'LM') then +-c +-c %--------------------------------------------% +-c | Sort X into increasing order of magnitude. | +-c %--------------------------------------------% +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +-c +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- temp1 = slapy2(real(x(j)),aimag(x(j))) +- temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) +-c +- if (temp1.gt.temp2) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 30 +- end if +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c %--------------------------------------------% +-c | Sort X into decreasing order of magnitude. | +-c %--------------------------------------------% +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +-c +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j .lt. 0) go to 60 +-c +- temp1 = slapy2(real(x(j)),aimag(x(j))) +- temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) +-c +- if (temp1.lt.temp2) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into increasing order of algebraic. | +-c %------------------------------------------------% +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +-c +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (real(x(j)).gt.real(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'SR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into decreasing order of algebraic. | +-c %------------------------------------------------% +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (real(x(j)).lt.real(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +-c +- else if (which .eq. 'LI') then +-c +-c %--------------------------------------------% +-c | Sort XIMAG into increasing algebraic order | +-c %--------------------------------------------% +-c +- 130 continue +- if (igap .eq. 0) go to 9000 +- do 150 i = igap, n-1 +- j = i-igap +- 140 continue +-c +- if (j.lt.0) go to 150 +-c +- if (aimag(x(j)).gt.aimag(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 150 +- endif +- j = j-igap +- go to 140 +- 150 continue +- igap = igap / 2 +- go to 130 +-c +- else if (which .eq. 'SI') then +-c +-c %---------------------------------------------% +-c | Sort XIMAG into decreasing algebraic order | +-c %---------------------------------------------% +-c +- 160 continue +- if (igap .eq. 0) go to 9000 +- do 180 i = igap, n-1 +- j = i-igap +- 170 continue +-c +- if (j.lt.0) go to 180 +-c +- if (aimag(x(j)).lt.aimag(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 180 +- endif +- j = j-igap +- go to 170 +- 180 continue +- igap = igap / 2 +- go to 160 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of csortc | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cstatn.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cstatn.f +deleted file mode 100644 +index 02f75e0b26..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/cstatn.f ++++ /dev/null +@@ -1,51 +0,0 @@ +-c +-c\SCCS Information: @(#) +-c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c %---------------------------------------------% +-c | Initialize statistic and timing information | +-c | for complex nonsymmetric Arnoldi code. | +-c %---------------------------------------------% +- +- subroutine cstatn +-c +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +-c +- include 'stat.h' +- +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +- +- nopx = 0 +- nbx = 0 +- nrorth = 0 +- nitref = 0 +- nrstrt = 0 +- +- tcaupd = 0.0E+0 +- tcaup2 = 0.0E+0 +- tcaitr = 0.0E+0 +- tceigh = 0.0E+0 +- tcgets = 0.0E+0 +- tcapps = 0.0E+0 +- tcconv = 0.0E+0 +- titref = 0.0E+0 +- tgetv0 = 0.0E+0 +- trvec = 0.0E+0 +- +-c %----------------------------------------------------% +-c | User time including reverse communication overhead | +-c %----------------------------------------------------% +- tmvopx = 0.0E+0 +- tmvbx = 0.0E+0 +- +- return +-c +-c %---------------% +-c | End of cstatn | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/debug.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/debug.h +deleted file mode 100644 +index 81a6efafb9..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/debug.h ++++ /dev/null +@@ -1,16 +0,0 @@ +- +-c\SCCS Information: @(#) +-c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 +-c +-c %---------------------------------% +-c | See debug.doc for documentation | +-c %---------------------------------% +-c integer logfil, ndigit, mgetv0, +-c & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, +-c & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, +-c & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd +-c common /debug/ +-c & logfil, ndigit, mgetv0, +-c & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, +-c & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, +-c & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dgetv0.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dgetv0.f +deleted file mode 100644 +index 1d6dc01bdb..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dgetv0.f ++++ /dev/null +@@ -1,421 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dgetv0 +-c +-c\Description: +-c Generate a random initial residual vector for the Arnoldi process. +-c Force the residual vector to be in the range of the operator OP. +-c +-c\Usage: +-c call dgetv0 +-c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, +-c IPNTR, WORKD, IERR ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to dgetv0. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B in the (generalized) +-c eigenvalue problem A*x = lambda*B*x. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c ITRY Integer. (INPUT) +-c ITRY counts the number of times that dgetv0 is called. +-c It should be set to 1 on the initial call to dgetv0. +-c +-c INITV Logical variable. (INPUT) +-c .TRUE. => the initial residual vector is given in RESID. +-c .FALSE. => generate a random initial residual vector. +-c +-c N Integer. (INPUT) +-c Dimension of the problem. +-c +-c J Integer. (INPUT) +-c Index of the residual vector to be generated, with respect to +-c the Arnoldi process. J > 1 in case of a "restart". +-c +-c V Double precision N by J array. (INPUT) +-c The first J-1 columns of V contain the current Arnoldi basis +-c if this is a "restart". +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c RESID Double precision array of length N. (INPUT/OUTPUT) +-c Initial residual vector to be generated. If RESID is +-c provided, force RESID into the range of the operator OP. +-c +-c RNORM Double precision scalar. (OUTPUT) +-c B-norm of the generated residual. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c +-c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION). +-c On exit, WORK(1:N) = B*RESID to be used in SSAITR. +-c +-c IERR Integer. (OUTPUT) +-c = 0: Normal exit. +-c = -1: Cannot generate a nontrivial restarted residual vector +-c in the range of the operator OP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine for vector output. +-c dlarnv LAPACK routine for generating a random vector. +-c dgemv Level 2 BLAS routine for matrix vector multiplication. +-c dcopy Level 1 BLAS that copies one vector to another. +-c ddot Level 1 BLAS that computes the scalar product of two vectors. +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dgetv0 +- & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, +- & ipntr, workd, ierr ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- logical initv +- integer ido, ierr, itry, j, ldv, n +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Double precision +- & resid(n), v(ldv,j), workd(2*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical first, inits, orth +- integer idist, iseed(4), iter, msglvl, jj +- Double precision +- & rnorm0 +- save first, iseed, inits, iter, msglvl, orth, rnorm0 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dlarnv, dvout, dcopy, dgemv, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & ddot, dnrm2 +- external ddot, dnrm2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs, sqrt +-c +-c %-----------------% +-c | Data Statements | +-c %-----------------% +-c +- data inits /.true./ +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c +-c %-----------------------------------% +-c | Initialize the seed of the LAPACK | +-c | random number generator | +-c %-----------------------------------% +-c +- if (inits) then +- iseed(1) = 1 +- iseed(2) = 3 +- iseed(3) = 5 +- iseed(4) = 7 +- inits = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mgetv0 +-c +- ierr = 0 +- iter = 0 +- first = .FALSE. +- orth = .FALSE. +-c +-c %-----------------------------------------------------% +-c | Possibly generate a random starting vector in RESID | +-c | Use a LAPACK random number generator used by the | +-c | matrix generation routines. | +-c | idist = 1: uniform (0,1) distribution; | +-c | idist = 2: uniform (-1,1) distribution; | +-c | idist = 3: normal (0,1) distribution; | +-c %-----------------------------------------------------% +-c +- if (.not.initv) then +- idist = 2 +- call dlarnv (idist, iseed, n, resid) +- end if +-c +-c %----------------------------------------------------------% +-c | Force the starting vector into the range of OP to handle | +-c | the generalized problem when B is possibly (singular). | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (itry .eq. 1) then +- nopx = nopx + 1 +- ipntr(1) = 1 +- ipntr(2) = n + 1 +- call dcopy (n, resid, 1, workd, 1) +- ido = -1 +- go to 9000 +- else if (itry .gt. 1 .and. bmat .eq. 'G') then +- call dcopy (n, resid, 1, workd(n + 1), 1) +- end if +- end if +-c +-c %-----------------------------------------% +-c | Back from computing OP*(initial-vector) | +-c %-----------------------------------------% +-c +- if (first) go to 20 +-c +-c %-----------------------------------------------% +-c | Back from computing OP*(orthogonalized-vector) | +-c %-----------------------------------------------% +-c +- if (orth) go to 40 +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +- end if +-c +-c %------------------------------------------------------% +-c | Starting vector is now in the range of OP; r = OP*r; | +-c | Compute B-norm of starting vector. | +-c %------------------------------------------------------% +-c +- call arscnd (t2) +- first = .TRUE. +- if (itry .eq. 1) call dcopy (n, workd(n + 1), 1, resid, 1) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd, 1) +- end if +-c +- 20 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- first = .FALSE. +- if (bmat .eq. 'G') then +- rnorm0 = ddot (n, resid, 1, workd, 1) +- rnorm0 = sqrt(abs(rnorm0)) +- else if (bmat .eq. 'I') then +- rnorm0 = dnrm2(n, resid, 1) +- end if +- rnorm = rnorm0 +-c +-c %---------------------------------------------% +-c | Exit if this is the very first Arnoldi step | +-c %---------------------------------------------% +-c +- if (j .eq. 1) go to 50 +-c +-c %---------------------------------------------------------------- +-c | Otherwise need to B-orthogonalize the starting vector against | +-c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | +-c | This is the case where an invariant subspace is encountered | +-c | in the middle of the Arnoldi factorization. | +-c | | +-c | s = V^{T}*B*r; r = r - V*s; | +-c | | +-c | Stopping criteria used for iter. ref. is discussed in | +-c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | +-c %---------------------------------------------------------------% +-c +- orth = .TRUE. +- 30 continue +-c +- call dgemv ('T', n, j-1, one, v, ldv, workd, 1, +- & zero, workd(n+1), 1) +- call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, +- & one, resid, 1) +-c +-c %----------------------------------------------------------% +-c | Compute the B-norm of the orthogonalized starting vector | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd, 1) +- end if +-c +- 40 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- rnorm = ddot (n, resid, 1, workd, 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = dnrm2(n, resid, 1) +- end if +-c +-c %--------------------------------------% +-c | Check for further orthogonalization. | +-c %--------------------------------------% +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, 1, [rnorm0], ndigit, +- & '_getv0: re-orthonalization ; rnorm0 is') +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_getv0: re-orthonalization ; rnorm is') +- end if +-c +- if (rnorm .gt. 0.717*rnorm0) go to 50 +-c +- iter = iter + 1 +- if (iter .le. 5) then +-c +-c %-----------------------------------% +-c | Perform iterative refinement step | +-c %-----------------------------------% +-c +- rnorm0 = rnorm +- go to 30 +- else +-c +-c %------------------------------------% +-c | Iterative refinement step "failed" | +-c %------------------------------------% +-c +- do 45 jj = 1, n +- resid(jj) = zero +- 45 continue +- rnorm = zero +- ierr = -1 +- end if +-c +- 50 continue +-c +- if (msglvl .gt. 0) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_getv0: B-norm of initial / restarted starting vector') +- end if +- if (msglvl .gt. 3) then +- call dvout (logfil, n, resid, ndigit, +- & '_getv0: initial / restarted starting vector') +- end if +- ido = 99 +-c +- call arscnd (t1) +- tgetv0 = tgetv0 + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dgetv0 | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaitr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaitr.f +deleted file mode 100644 +index c02cd39092..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaitr.f ++++ /dev/null +@@ -1,840 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dnaitr +-c +-c\Description: +-c Reverse communication interface for applying NP additional steps to +-c a K step nonsymmetric Arnoldi factorization. +-c +-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +-c +-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +-c +-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +-c +-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +-c +-c where OP and B are as in dnaupd. The B-norm of r_{k+p} is also +-c computed and returned. +-c +-c\Usage: +-c call dnaitr +-c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c This is for the restart phase to force the new +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y, +-c IPNTR(3) is the pointer into WORK for B * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c When the routine is used in the "shift-and-invert" mode, the +-c vector B * Q is already available and do not need to be +-c recompute in forming OP * Q. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. See dnaupd. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c K Integer. (INPUT) +-c Current size of V and H. +-c +-c NP Integer. (INPUT) +-c Number of additional Arnoldi steps to take. +-c +-c NB Integer. (INPUT) +-c Blocksize to be used in the recurrence. +-c Only work for NB = 1 right now. The goal is to have a +-c program that implement both the block and non-block method. +-c +-c RESID Double precision array of length N. (INPUT/OUTPUT) +-c On INPUT: RESID contains the residual vector r_{k}. +-c On OUTPUT: RESID contains the residual vector r_{k+p}. +-c +-c RNORM Double precision scalar. (INPUT/OUTPUT) +-c B-norm of the starting residual on input. +-c B-norm of the updated residual r_{k+p} on output. +-c +-c V Double precision N by K+NP array. (INPUT/OUTPUT) +-c On INPUT: V contains the Arnoldi vectors in the first K +-c columns. +-c On OUTPUT: V contains the new NP Arnoldi vectors in the next +-c NP columns. The first K columns are unchanged. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT) +-c H is used to store the generated upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORK for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The calling program should not +-c use WORKD as temporary workspace during the iteration !!!!!! +-c On input, WORKD(1:N) = B*RESID and is used to save some +-c computation at the first step. +-c +-c INFO Integer. (OUTPUT) +-c = 0: Normal exit. +-c > 0: Size of the spanning invariant subspace of OP found. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c dgetv0 ARPACK routine to generate the initial vector. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dmout ARPACK utility routine that prints matrices +-c dvout ARPACK utility routine that prints vectors. +-c dlabad LAPACK routine that computes machine constants. +-c dlamch LAPACK routine that determines machine constants. +-c dlascl LAPACK routine for careful scaling of a matrix. +-c dlanhs LAPACK routine that computes various norms of a matrix. +-c dgemv Level 2 BLAS routine for matrix vector multiplication. +-c daxpy Level 1 BLAS that computes a vector triad. +-c dscal Level 1 BLAS that scales a vector. +-c dcopy Level 1 BLAS that copies one vector to another . +-c ddot Level 1 BLAS that computes the scalar product of two vectors. +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c The algorithm implemented is: +-c +-c restart = .false. +-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +-c r_{k} contains the initial residual vector even for k = 0; +-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +-c computed by the calling program. +-c +-c betaj = rnorm ; p_{k+1} = B*r_{k} ; +-c For j = k+1, ..., k+np Do +-c 1) if ( betaj < tol ) stop or restart depending on j. +-c ( At present tol is zero ) +-c if ( restart ) generate a new starting vector. +-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +-c p_{j} = p_{j}/betaj +-c 3) r_{j} = OP*v_{j} where OP is defined as in dnaupd +-c For shift-invert mode p_{j} = B*v_{j} is already available. +-c wnorm = || OP*v_{j} || +-c 4) Compute the j-th step residual vector. +-c w_{j} = V_{j}^T * B * OP * v_{j} +-c r_{j} = OP*v_{j} - V_{j} * w_{j} +-c H(:,j) = w_{j}; +-c H(j,j-1) = rnorm +-c rnorm = || r_(j) || +-c If (rnorm > 0.717*wnorm) accept step and go back to 1) +-c 5) Re-orthogonalization step: +-c s = V_{j}'*B*r_{j} +-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +-c alphaj = alphaj + s_{j}; +-c 6) Iterative refinement step: +-c If (rnorm1 > 0.717*rnorm) then +-c rnorm = rnorm1 +-c accept step and go back to 1) +-c Else +-c rnorm = rnorm1 +-c If this is the first time in step 6), go to 5) +-c Else r_{j} lies in the span of V_{j} numerically. +-c Set r_{j} = 0 and rnorm = 0; go to 1) +-c EndIf +-c End Do +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dnaitr +- & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, +- & ipntr, workd, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- integer ido, info, k, ldh, ldv, n, nb, np +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Double precision +- & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical first, orth1, orth2, rstart, step3, step4 +- integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, +- & jj +- Double precision +- & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, +- & wnorm +- save first, orth1, orth2, rstart, step3, step4, +- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, +- & betaj, rnorm1, smlnum, ulp, unfl, wnorm +-c +-c %-----------------------% +-c | Local Array Arguments | +-c %-----------------------% +-c +- Double precision +- & xtemp(2) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external daxpy, dcopy, dscal, dgemv, dgetv0, dlabad, +- & dvout, dmout, ivout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & ddot, dnrm2, dlanhs, dlamch +- external ddot, dnrm2, dlanhs, dlamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs, sqrt +-c +-c %-----------------% +-c | Data statements | +-c %-----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------% +-c | Set machine-dependent constants for the | +-c | the splitting and deflation criterion. | +-c | If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine dlahqr | +-c %-----------------------------------------% +-c +- unfl = dlamch( 'safe minimum' ) +- ovfl = one / unfl +- call dlabad( unfl, ovfl ) +- ulp = dlamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mnaitr +-c +-c %------------------------------% +-c | Initial call to this routine | +-c %------------------------------% +-c +- info = 0 +- step3 = .false. +- step4 = .false. +- rstart = .false. +- orth1 = .false. +- orth2 = .false. +- j = k + 1 +- ipj = 1 +- irj = ipj + n +- ivj = irj + n +- end if +-c +-c %-------------------------------------------------% +-c | When in reverse communication mode one of: | +-c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +-c | will be .true. when .... | +-c | STEP3: return from computing OP*v_{j}. | +-c | STEP4: return from computing B-norm of OP*v_{j} | +-c | ORTH1: return from computing B-norm of r_{j+1} | +-c | ORTH2: return from computing B-norm of | +-c | correction to the residual vector. | +-c | RSTART: return from OP computations needed by | +-c | dgetv0. | +-c %-------------------------------------------------% +-c +- if (step3) go to 50 +- if (step4) go to 60 +- if (orth1) go to 70 +- if (orth2) go to 90 +- if (rstart) go to 30 +-c +-c %-----------------------------% +-c | Else this is the first step | +-c %-----------------------------% +-c +-c %--------------------------------------------------------------% +-c | | +-c | A R N O L D I I T E R A T I O N L O O P | +-c | | +-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +-c %--------------------------------------------------------------% +- +- 1000 continue +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: generating Arnoldi vector number') +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_naitr: B-norm of the current residual is') +- end if +-c +-c %---------------------------------------------------% +-c | STEP 1: Check if the B norm of j-th residual | +-c | vector is zero. Equivalent to determining whether | +-c | an exact j-step Arnoldi factorization is present. | +-c %---------------------------------------------------% +-c +- betaj = rnorm +- if (rnorm .gt. zero) go to 40 +-c +-c %---------------------------------------------------% +-c | Invariant subspace found, generate a new starting | +-c | vector which is orthogonal to the current Arnoldi | +-c | basis and continue the iteration. | +-c %---------------------------------------------------% +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: ****** RESTART AT STEP ******') +- end if +-c +-c %---------------------------------------------% +-c | ITRY is the loop variable that controls the | +-c | maximum amount of times that a restart is | +-c | attempted. NRSTRT is used by stat.h | +-c %---------------------------------------------% +-c +- betaj = zero +- nrstrt = nrstrt + 1 +- itry = 1 +- 20 continue +- rstart = .true. +- ido = 0 +- 30 continue +-c +-c %--------------------------------------% +-c | If in reverse communication mode and | +-c | RSTART = .true. flow returns here. | +-c %--------------------------------------% +-c +- call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, +- & resid, rnorm, ipntr, workd, ierr) +- if (ido .ne. 99) go to 9000 +- if (ierr .lt. 0) then +- itry = itry + 1 +- if (itry .le. 3) go to 20 +-c +-c %------------------------------------------------% +-c | Give up after several restart attempts. | +-c | Set INFO to the size of the invariant subspace | +-c | which spans OP and exit. | +-c %------------------------------------------------% +-c +- info = j - 1 +- call arscnd (t1) +- tnaitr = tnaitr + (t1 - t0) +- ido = 99 +- go to 9000 +- end if +-c +- 40 continue +-c +-c %---------------------------------------------------------% +-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +-c | when reciprocating a small RNORM, test against lower | +-c | machine bound. | +-c %---------------------------------------------------------% +-c +- call dcopy (n, resid, 1, v(1,j), 1) +- if (rnorm .ge. unfl) then +- temp1 = one / rnorm +- call dscal (n, temp1, v(1,j), 1) +- call dscal (n, temp1, workd(ipj), 1) +- else +-c +-c %-----------------------------------------% +-c | To scale both v_{j} and p_{j} carefully | +-c | use LAPACK routine SLASCL | +-c %-----------------------------------------% +-c +- call dlascl ('General', i, i, rnorm, one, n, 1, +- & v(1,j), n, infol) +- call dlascl ('General', i, i, rnorm, one, n, 1, +- & workd(ipj), n, infol) +- end if +-c +-c %------------------------------------------------------% +-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +-c | Note that this is not quite yet r_{j}. See STEP 4 | +-c %------------------------------------------------------% +-c +- step3 = .true. +- nopx = nopx + 1 +- call arscnd (t2) +- call dcopy (n, v(1,j), 1, workd(ivj), 1) +- ipntr(1) = ivj +- ipntr(2) = irj +- ipntr(3) = ipj +- ido = 1 +-c +-c %-----------------------------------% +-c | Exit in order to compute OP*v_{j} | +-c %-----------------------------------% +-c +- go to 9000 +- 50 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | +-c | if step3 = .true. | +-c %----------------------------------% +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +- +- step3 = .false. +-c +-c %------------------------------------------% +-c | Put another copy of OP*v_{j} into RESID. | +-c %------------------------------------------% +-c +- call dcopy (n, workd(irj), 1, resid, 1) +-c +-c %---------------------------------------% +-c | STEP 4: Finish extending the Arnoldi | +-c | factorization to length j. | +-c %---------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- step4 = .true. +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-------------------------------------% +-c | Exit in order to compute B*OP*v_{j} | +-c %-------------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd(ipj), 1) +- end if +- 60 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | +-c | if step4 = .true. | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- step4 = .false. +-c +-c %-------------------------------------% +-c | The following is needed for STEP 5. | +-c | Compute the B-norm of OP*v_{j}. | +-c %-------------------------------------% +-c +- if (bmat .eq. 'G') then +- wnorm = ddot (n, resid, 1, workd(ipj), 1) +- wnorm = sqrt(abs(wnorm)) +- else if (bmat .eq. 'I') then +- wnorm = dnrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------% +-c | Compute the j-th residual corresponding | +-c | to the j step factorization. | +-c | Use Classical Gram Schmidt and compute: | +-c | w_{j} <- V_{j}^T * B * OP * v_{j} | +-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +-c %-----------------------------------------% +-c +-c +-c %------------------------------------------% +-c | Compute the j Fourier coefficients w_{j} | +-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +-c %------------------------------------------% +-c +- call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, +- & zero, h(1,j), 1) +-c +-c %--------------------------------------% +-c | Orthogonalize r_{j} against V_{j}. | +-c | RESID contains OP*v_{j}. See STEP 3. | +-c %--------------------------------------% +-c +- call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1, +- & one, resid, 1) +-c +- if (j .gt. 1) h(j,j-1) = betaj +-c +- call arscnd (t4) +-c +- orth1 = .true. +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*r_{j} | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd(ipj), 1) +- end if +- 70 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH1 = .true. | +-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- orth1 = .false. +-c +-c %------------------------------% +-c | Compute the B-norm of r_{j}. | +-c %------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm = ddot (n, resid, 1, workd(ipj), 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = dnrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------------------------% +-c | STEP 5: Re-orthogonalization / Iterative refinement phase | +-c | Maximum NITER_ITREF tries. | +-c | | +-c | s = V_{j}^T * B * r_{j} | +-c | r_{j} = r_{j} - V_{j}*s | +-c | alphaj = alphaj + s_{j} | +-c | | +-c | The stopping criteria used for iterative refinement is | +-c | discussed in Parlett's book SEP, page 107 and in Gragg & | +-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +-c | Determine if we need to correct the residual. The goal is | +-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +-c | The following test determines whether the sine of the | +-c | angle between OP*x and the computed residual is less | +-c | than or equal to 0.717. | +-c %-----------------------------------------------------------% +-c +- if (rnorm .gt. 0.717*wnorm) go to 100 +- iter = 0 +- nrorth = nrorth + 1 +-c +-c %---------------------------------------------------% +-c | Enter the Iterative refinement phase. If further | +-c | refinement is necessary, loop back here. The loop | +-c | variable is ITER. Perform a step of Classical | +-c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +-c %---------------------------------------------------% +-c +- 80 continue +-c +- if (msglvl .gt. 2) then +- xtemp(1) = wnorm +- xtemp(2) = rnorm +- call dvout (logfil, 2, xtemp, ndigit, +- & '_naitr: re-orthonalization; wnorm and rnorm are') +- call dvout (logfil, j, h(1,j), ndigit, +- & '_naitr: j-th column of H') +- end if +-c +-c %----------------------------------------------------% +-c | Compute V_{j}^T * B * r_{j}. | +-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +-c %----------------------------------------------------% +-c +- call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, +- & zero, workd(irj), 1) +-c +-c %---------------------------------------------% +-c | Compute the correction to the residual: | +-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +-c | The correction to H is v(:,1:J)*H(1:J,1:J) | +-c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | +-c %---------------------------------------------% +-c +- call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, +- & one, resid, 1) +- call daxpy (j, one, workd(irj), 1, h(1,j), 1) +-c +- orth2 = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-----------------------------------% +-c | Exit in order to compute B*r_{j}. | +-c | r_{j} is the corrected residual. | +-c %-----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd(ipj), 1) +- end if +- 90 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH2 = .true. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +-c %-----------------------------------------------------% +-c | Compute the B-norm of the corrected residual r_{j}. | +-c %-----------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm1 = ddot (n, resid, 1, workd(ipj), 1) +- rnorm1 = sqrt(abs(rnorm1)) +- else if (bmat .eq. 'I') then +- rnorm1 = dnrm2(n, resid, 1) +- end if +-c +- if (msglvl .gt. 0 .and. iter .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: Iterative refinement for Arnoldi residual') +- if (msglvl .gt. 2) then +- xtemp(1) = rnorm +- xtemp(2) = rnorm1 +- call dvout (logfil, 2, xtemp, ndigit, +- & '_naitr: iterative refinement ; rnorm and rnorm1 are') +- end if +- end if +-c +-c %-----------------------------------------% +-c | Determine if we need to perform another | +-c | step of re-orthogonalization. | +-c %-----------------------------------------% +-c +- if (rnorm1 .gt. 0.717*rnorm) then +-c +-c %---------------------------------------% +-c | No need for further refinement. | +-c | The cosine of the angle between the | +-c | corrected residual vector and the old | +-c | residual vector is greater than 0.717 | +-c | In other words the corrected residual | +-c | and the old residual vector share an | +-c | angle of less than arcCOS(0.717) | +-c %---------------------------------------% +-c +- rnorm = rnorm1 +-c +- else +-c +-c %-------------------------------------------% +-c | Another step of iterative refinement step | +-c | is required. NITREF is used by stat.h | +-c %-------------------------------------------% +-c +- nitref = nitref + 1 +- rnorm = rnorm1 +- iter = iter + 1 +- if (iter .le. 1) go to 80 +-c +-c %-------------------------------------------------% +-c | Otherwise RESID is numerically in the span of V | +-c %-------------------------------------------------% +-c +- do 95 jj = 1, n +- resid(jj) = zero +- 95 continue +- rnorm = zero +- end if +-c +-c %----------------------------------------------% +-c | Branch here directly if iterative refinement | +-c | wasn't necessary or after at most NITER_REF | +-c | steps of iterative refinement. | +-c %----------------------------------------------% +-c +- 100 continue +-c +- rstart = .false. +- orth2 = .false. +-c +- call arscnd (t5) +- titref = titref + (t5 - t4) +-c +-c %------------------------------------% +-c | STEP 6: Update j = j+1; Continue | +-c %------------------------------------% +-c +- j = j + 1 +- if (j .gt. k+np) then +- call arscnd (t1) +- tnaitr = tnaitr + (t1 - t0) +- ido = 99 +- do 110 i = max(1,k), k+np-1 +-c +-c %--------------------------------------------% +-c | Check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine dlahqr | +-c %--------------------------------------------% +-c +- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) +- if( tst1.eq.zero ) +- & tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) ) +- if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 110 continue +-c +- if (msglvl .gt. 2) then +- call dmout (logfil, k+np, k+np, h, ldh, ndigit, +- & '_naitr: Final upper Hessenberg matrix H of order K+NP') +- end if +-c +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Loop back to extend the factorization by another step. | +-c %--------------------------------------------------------% +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dnaitr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnapps.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnapps.f +deleted file mode 100644 +index 1cf3725696..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnapps.f ++++ /dev/null +@@ -1,649 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dnapps +-c +-c\Description: +-c Given the Arnoldi factorization +-c +-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +-c +-c apply NP implicit shifts resulting in +-c +-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +-c +-c where Q is an orthogonal matrix which is the product of rotations +-c and reflections resulting from the NP bulge change sweeps. +-c The updated Arnoldi factorization becomes: +-c +-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +-c +-c\Usage: +-c call dnapps +-c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, +-c WORKL, WORKD ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Problem size, i.e. size of matrix A. +-c +-c KEV Integer. (INPUT/OUTPUT) +-c KEV+NP is the size of the input matrix H. +-c KEV is the size of the updated matrix HNEW. KEV is only +-c updated on output when fewer than NP shifts are applied in +-c order to keep the conjugate pair together. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be applied. +-c +-c SHIFTR, Double precision array of length NP. (INPUT) +-c SHIFTI Real and imaginary part of the shifts to be applied. +-c Upon, entry to dnapps, the shifts must be sorted so that the +-c conjugate pairs are in consecutive locations. +-c +-c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, V contains the current KEV+NP Arnoldi vectors. +-c On OUTPUT, V contains the updated KEV Arnoldi vectors +-c in the first KEV columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, H contains the current KEV+NP by KEV+NP upper +-c Hessenber matrix of the Arnoldi factorization. +-c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg +-c matrix in the KEV leading submatrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RESID Double precision array of length N. (INPUT/OUTPUT) +-c On INPUT, RESID contains the the residual vector r_{k+p}. +-c On OUTPUT, RESID is the update residual vector rnew_{k} +-c in the first KEV locations. +-c +-c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) +-c Work array used to accumulate the rotations and reflections +-c during the bulge chase sweep. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Double precision work array of length (KEV+NP). (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c WORKD Double precision work array of length 2*N. (WORKSPACE) +-c Distributed array used in the application of the accumulated +-c orthogonal matrix Q. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dmout ARPACK utility routine that prints matrices. +-c dvout ARPACK utility routine that prints vectors. +-c dlabad LAPACK routine that computes machine constants. +-c dlacpy LAPACK matrix copy routine. +-c dlamch LAPACK routine that determines machine constants. +-c dlanhs LAPACK routine that computes various norms of a matrix. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c dlarf LAPACK routine that applies Householder reflection to +-c a matrix. +-c dlarfg LAPACK Householder reflection construction routine. +-c dlartg LAPACK Givens rotation construction routine. +-c dlaset LAPACK matrix initialization routine. +-c dgemv Level 2 BLAS routine for matrix vector multiplication. +-c daxpy Level 1 BLAS that computes a vector triad. +-c dcopy Level 1 BLAS that copies one vector to another . +-c dscal Level 1 BLAS that scales a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 +-c +-c\Remarks +-c 1. In this version, each shift is applied to all the sublocks of +-c the Hessenberg matrix H and not just to the submatrix that it +-c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm +-c for upper Hessenberg matrices ) is used. +-c The subdiagonals of H are enforced to be non-negative. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dnapps +- & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, +- & workl, workd ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer kev, ldh, ldq, ldv, n, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), +- & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr +- logical cconj, first +- Double precision +- & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, +- & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 +- save first, ovfl, smlnum, ulp, unfl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf, +- & dlaset, dlabad, arscnd, dlartg +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlamch, dlanhs, dlapy2 +- external dlamch, dlanhs, dlapy2 +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs, max, min +-c +-c %----------------% +-c | Data statements | +-c %----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------------% +-c | Set machine-dependent constants for the | +-c | stopping criterion. If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine dlahqr | +-c %-----------------------------------------------% +-c +- unfl = dlamch( 'safe minimum' ) +- ovfl = one / unfl +- call dlabad( unfl, ovfl ) +- ulp = dlamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mnapps +- kplusp = kev + np +-c +-c %--------------------------------------------% +-c | Initialize Q to the identity to accumulate | +-c | the rotations and reflections | +-c %--------------------------------------------% +-c +- call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) +-c +-c %----------------------------------------------% +-c | Quick return if there are no shifts to apply | +-c %----------------------------------------------% +-c +- if (np .eq. 0) go to 9000 +-c +-c %----------------------------------------------% +-c | Chase the bulge with the application of each | +-c | implicit shift. Each shift is applied to the | +-c | whole matrix including each block. | +-c %----------------------------------------------% +-c +- cconj = .false. +- do 110 jj = 1, np +- sigmar = shiftr(jj) +- sigmai = shifti(jj) +-c +- if (msglvl .gt. 2 ) then +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: shift number.') +- call dvout (logfil, 1, [sigmar], ndigit, +- & '_napps: The real part of the shift ') +- call dvout (logfil, 1, [sigmai], ndigit, +- & '_napps: The imaginary part of the shift ') +- end if +-c +-c %-------------------------------------------------% +-c | The following set of conditionals is necessary | +-c | in order that complex conjugate pairs of shifts | +-c | are applied together or not at all. | +-c %-------------------------------------------------% +-c +- if ( cconj ) then +-c +-c %-----------------------------------------% +-c | cconj = .true. means the previous shift | +-c | had non-zero imaginary part. | +-c %-----------------------------------------% +-c +- cconj = .false. +- go to 110 +- else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then +-c +-c %------------------------------------% +-c | Start of a complex conjugate pair. | +-c %------------------------------------% +-c +- cconj = .true. +- else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then +-c +-c %----------------------------------------------% +-c | The last shift has a nonzero imaginary part. | +-c | Don't apply it; thus the order of the | +-c | compressed H is order KEV+1 since only np-1 | +-c | were applied. | +-c %----------------------------------------------% +-c +- kev = kev + 1 +- go to 110 +- end if +- istart = 1 +- 20 continue +-c +-c %--------------------------------------------------% +-c | if sigmai = 0 then | +-c | Apply the jj-th shift ... | +-c | else | +-c | Apply the jj-th and (jj+1)-th together ... | +-c | (Note that jj < np at this point in the code) | +-c | end | +-c | to the current block of H. The next do loop | +-c | determines the current block ; | +-c %--------------------------------------------------% +-c +- do 30 i = istart, kplusp-1 +-c +-c %----------------------------------------% +-c | Check for splitting and deflation. Use | +-c | a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine dlahqr | +-c %----------------------------------------% +-c +- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) +- if( tst1.eq.zero ) +- & tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl ) +- if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_napps: matrix splitting at row/column no.') +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: matrix splitting with shift number.') +- call dvout (logfil, 1, h(i+1,i), ndigit, +- & '_napps: off diagonal element.') +- end if +- iend = i +- h(i+1,i) = zero +- go to 40 +- end if +- 30 continue +- iend = kplusp +- 40 continue +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [istart], ndigit, +- & '_napps: Start of current block ') +- call ivout (logfil, 1, [iend], ndigit, +- & '_napps: End of current block ') +- end if +-c +-c %------------------------------------------------% +-c | No reason to apply a shift to block of order 1 | +-c %------------------------------------------------% +-c +- if ( istart .eq. iend ) go to 100 +-c +-c %------------------------------------------------------% +-c | If istart + 1 = iend then no reason to apply a | +-c | complex conjugate pair of shifts on a 2 by 2 matrix. | +-c %------------------------------------------------------% +-c +- if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) +- & go to 100 +-c +- h11 = h(istart,istart) +- h21 = h(istart+1,istart) +- if ( abs( sigmai ) .le. zero ) then +-c +-c %---------------------------------------------% +-c | Real-valued shift ==> apply single shift QR | +-c %---------------------------------------------% +-c +- f = h11 - sigmar +- g = h21 +-c +- do 80 i = istart, iend-1 +-c +-c %-----------------------------------------------------% +-c | Construct the plane rotation G to zero out the bulge | +-c %-----------------------------------------------------% +-c +- call dlartg (f, g, c, s, r) +- if (i .gt. istart) then +-c +-c %-------------------------------------------% +-c | The following ensures that h(1:iend-1,1), | +-c | the first iend-2 off diagonal of elements | +-c | H, remain non negative. | +-c %-------------------------------------------% +-c +- if (r .lt. zero) then +- r = -r +- c = -c +- s = -s +- end if +- h(i,i-1) = r +- h(i+1,i-1) = zero +- end if +-c +-c %---------------------------------------------% +-c | Apply rotation to the left of H; H <- G'*H | +-c %---------------------------------------------% +-c +- do 50 j = i, kplusp +- t = c*h(i,j) + s*h(i+1,j) +- h(i+1,j) = -s*h(i,j) + c*h(i+1,j) +- h(i,j) = t +- 50 continue +-c +-c %---------------------------------------------% +-c | Apply rotation to the right of H; H <- H*G | +-c %---------------------------------------------% +-c +- do 60 j = 1, min(i+2,iend) +- t = c*h(j,i) + s*h(j,i+1) +- h(j,i+1) = -s*h(j,i) + c*h(j,i+1) +- h(j,i) = t +- 60 continue +-c +-c %----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G | +-c %----------------------------------------------------% +-c +- do 70 j = 1, min( i+jj, kplusp ) +- t = c*q(j,i) + s*q(j,i+1) +- q(j,i+1) = - s*q(j,i) + c*q(j,i+1) +- q(j,i) = t +- 70 continue +-c +-c %---------------------------% +-c | Prepare for next rotation | +-c %---------------------------% +-c +- if (i .lt. iend-1) then +- f = h(i+1,i) +- g = h(i+2,i) +- end if +- 80 continue +-c +-c %-----------------------------------% +-c | Finished applying the real shift. | +-c %-----------------------------------% +-c +- else +-c +-c %----------------------------------------------------% +-c | Complex conjugate shifts ==> apply double shift QR | +-c %----------------------------------------------------% +-c +- h12 = h(istart,istart+1) +- h22 = h(istart+1,istart+1) +- h32 = h(istart+2,istart+1) +-c +-c %---------------------------------------------------------% +-c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | +-c %---------------------------------------------------------% +-c +- s = 2.0*sigmar +- t = dlapy2 ( sigmar, sigmai ) +- u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 +- u(2) = h11 + h22 - s +- u(3) = h32 +-c +- do 90 i = istart, iend-1 +-c +- nr = min ( 3, iend-i+1 ) +-c +-c %-----------------------------------------------------% +-c | Construct Householder reflector G to zero out u(1). | +-c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | +-c %-----------------------------------------------------% +-c +- call dlarfg ( nr, u(1), u(2), 1, tau ) +-c +- if (i .gt. istart) then +- h(i,i-1) = u(1) +- h(i+1,i-1) = zero +- if (i .lt. iend-1) h(i+2,i-1) = zero +- end if +- u(1) = one +-c +-c %--------------------------------------% +-c | Apply the reflector to the left of H | +-c %--------------------------------------% +-c +- call dlarf ('Left', nr, kplusp-i+1, u, 1, tau, +- & h(i,i), ldh, workl) +-c +-c %---------------------------------------% +-c | Apply the reflector to the right of H | +-c %---------------------------------------% +-c +- ir = min ( i+3, iend ) +- call dlarf ('Right', ir, nr, u, 1, tau, +- & h(1,i), ldh, workl) +-c +-c %-----------------------------------------------------% +-c | Accumulate the reflector in the matrix Q; Q <- Q*G | +-c %-----------------------------------------------------% +-c +- call dlarf ('Right', kplusp, nr, u, 1, tau, +- & q(1,i), ldq, workl) +-c +-c %----------------------------% +-c | Prepare for next reflector | +-c %----------------------------% +-c +- if (i .lt. iend-1) then +- u(1) = h(i+1,i) +- u(2) = h(i+2,i) +- if (i .lt. iend-2) u(3) = h(i+3,i) +- end if +-c +- 90 continue +-c +-c %--------------------------------------------% +-c | Finished applying a complex pair of shifts | +-c | to the current block | +-c %--------------------------------------------% +-c +- end if +-c +- 100 continue +-c +-c %---------------------------------------------------------% +-c | Apply the same shift to the next block if there is any. | +-c %---------------------------------------------------------% +-c +- istart = iend + 1 +- if (iend .lt. kplusp) go to 20 +-c +-c %---------------------------------------------% +-c | Loop back to the top to get the next shift. | +-c %---------------------------------------------% +-c +- 110 continue +-c +-c %--------------------------------------------------% +-c | Perform a similarity transformation that makes | +-c | sure that H will have non negative sub diagonals | +-c %--------------------------------------------------% +-c +- do 120 j=1,kev +- if ( h(j+1,j) .lt. zero ) then +- call dscal( kplusp-j+1, -one, h(j+1,j), ldh ) +- call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) +- call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) +- end if +- 120 continue +-c +- do 130 i = 1, kev +-c +-c %--------------------------------------------% +-c | Final check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine dlahqr | +-c %--------------------------------------------% +-c +- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) +- if( tst1.eq.zero ) +- & tst1 = dlanhs( '1', kev, h, ldh, workl ) +- if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 130 continue +-c +-c %-------------------------------------------------% +-c | Compute the (kev+1)-st column of (V*Q) and | +-c | temporarily store the result in WORKD(N+1:2*N). | +-c | This is needed in the residual update since we | +-c | cannot GUARANTEE that the corresponding entry | +-c | of H would be zero as in exact arithmetic. | +-c %-------------------------------------------------% +-c +- if (h(kev+1,kev) .gt. zero) +- & call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, +- & workd(n+1), 1) +-c +-c %----------------------------------------------------------% +-c | Compute column 1 to kev of (V*Q) in backward order | +-c | taking advantage of the upper Hessenberg structure of Q. | +-c %----------------------------------------------------------% +-c +- do 140 i = 1, kev +- call dgemv ('N', n, kplusp-i+1, one, v, ldv, +- & q(1,kev-i+1), 1, zero, workd, 1) +- call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) +- 140 continue +-c +-c %-------------------------------------------------% +-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +-c %-------------------------------------------------% +-c +- do 150 i = 1, kev +- call dcopy(n, v(1,kplusp-kev+i), 1, v(1,i), 1) +- 150 continue +-c +-c %--------------------------------------------------------------% +-c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | +-c %--------------------------------------------------------------% +-c +- if (h(kev+1,kev) .gt. zero) +- & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) +-c +-c %-------------------------------------% +-c | Update the residual vector: | +-c | r <- sigmak*r + betak*v(:,kev+1) | +-c | where | +-c | sigmak = (e_{kplusp}'*Q)*e_{kev} | +-c | betak = e_{kev+1}'*H*e_{kev} | +-c %-------------------------------------% +-c +- call dscal (n, q(kplusp,kev), resid, 1) +- if (h(kev+1,kev) .gt. zero) +- & call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, 1, q(kplusp,kev), ndigit, +- & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') +- call dvout (logfil, 1, h(kev+1,kev), ndigit, +- & '_napps: betak = e_{kev+1}^T*H*e_{kev}') +- call ivout (logfil, 1, [kev], ndigit, +- & '_napps: Order of the final Hessenberg matrix ') +- if (msglvl .gt. 2) then +- call dmout (logfil, kev, kev, h, ldh, ndigit, +- & '_napps: updated Hessenberg matrix H for next iteration') +- end if +-c +- end if +-c +- 9000 continue +- call arscnd (t1) +- tnapps = tnapps + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of dnapps | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaup2.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaup2.f +deleted file mode 100644 +index 86375a6469..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaup2.f ++++ /dev/null +@@ -1,846 +0,0 @@ +-c\BeginDoc +-c +-c\Name: dnaup2 +-c +-c\Description: +-c Intermediate level interface called by dnaupd . +-c +-c\Usage: +-c call dnaup2 +-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +-c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, +-c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c +-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dnaupd . +-c MODE, ISHIFT, MXITER: see the definition of IPARAM in dnaupd . +-c +-c NP Integer. (INPUT/OUTPUT) +-c Contains the number of implicit shifts to apply during +-c each Arnoldi iteration. +-c If ISHIFT=1, NP is adjusted dynamically at each iteration +-c to accelerate convergence and prevent stagnation. +-c This is also roughly equal to the number of matrix-vector +-c products (involving the operator OP) per Arnoldi iteration. +-c The logic for adjusting is contained within the current +-c subroutine. +-c If ISHIFT=0, NP is the number of shifts the user needs +-c to provide via reverse communication. 0 < NP < NCV-NEV. +-c NP may be less than NCV-NEV for two reasons. The first, is +-c to keep complex conjugate pairs of "wanted" Ritz values +-c together. The second, is that a leading block of the current +-c upper Hessenberg matrix has split off and contains "unwanted" +-c Ritz values. +-c Upon termination of the IRA iteration, NP contains the number +-c of "converged" wanted Ritz values. +-c +-c IUPD Integer. (INPUT) +-c IUPD .EQ. 0: use explicit restart instead implicit update. +-c IUPD .NE. 0: use implicit update. +-c +-c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) +-c The Arnoldi basis vectors are returned in the first NEV +-c columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT) +-c H is used to store the generated upper Hessenberg matrix +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZR, Double precision arrays of length NEV+NP. (OUTPUT) +-c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. +-c imaginary) part of the computed Ritz values of OP. +-c +-c BOUNDS Double precision array of length NEV+NP. (OUTPUT) +-c BOUNDS(1:NEV) contain the error bounds corresponding to +-c the computed Ritz values. +-c +-c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) +-c Private (replicated) work array used to accumulate the +-c rotation in the shift application step. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Double precision work array of length at least +-c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. It is used in shifts calculation, shifts +-c application and convergence checking. +-c +-c On exit, the last 3*(NEV+NP) locations of WORKL contain +-c the Ritz values (real,imaginary) and associated Ritz +-c estimates of the current Hessenberg matrix. They are +-c listed in the same order as returned from dneigh . +-c +-c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations +-c of WORKL are used in reverse communication to hold the user +-c supplied shifts. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Double precision work array of length 3*N. (WORKSPACE) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note in DNAUPD. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal return. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. +-c NP returns the number of converged Ritz values. +-c = 2: No shifts could be applied. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c This should never happen. +-c = -9: Starting vector is zero. +-c = -9999: Could not build an Arnoldi factorization. +-c Size that was built in returned in NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c dgetv0 ARPACK initial vector generation routine. +-c dnaitr ARPACK Arnoldi factorization routine. +-c dnapps ARPACK application of implicit shifts routine. +-c dnconv ARPACK convergence of Ritz values routine. +-c dneigh ARPACK compute Ritz values and error bounds routine. +-c dngets ARPACK reorder Ritz values and error bounds routine. +-c dsortc ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dmout ARPACK utility routine that prints matrices +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c dcopy Level 1 BLAS that copies one vector to another . +-c ddot Level 1 BLAS that computes the scalar product of two vectors. +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c dswap Level 1 BLAS that swaps two vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 +-c +-c\Remarks +-c 1. None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dnaup2 +- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, +- & q, ldq, workl, ipntr, workd, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, +- & n, nev, np +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(13) +- Double precision +- & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), +- & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), +- & workd(3*n), workl( (nev+np)*(nev+np+3) ) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0 , zero = 0.0D+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character wprime*2 +- logical cnorm , getv0, initv, update, ushift +- integer ierr , iter , j , kplusp, msglvl, nconv, +- & nevbef, nev0 , np0 , nptemp, numcnv +- Double precision +- & rnorm , temp , eps23 +- save cnorm , getv0, initv, update, ushift, +- & rnorm , iter , eps23, kplusp, msglvl, nconv , +- & nevbef, nev0 , np0 , numcnv +-c +-c %-----------------------% +-c | Local array arguments | +-c %-----------------------% +-c +- integer kp(4) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy , dgetv0 , dnaitr , dnconv , dneigh , +- & dngets , dnapps , dvout , ivout , arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & ddot , dnrm2 , dlapy2 , dlamch +- external ddot , dnrm2 , dlapy2 , dlamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic min, max, abs, sqrt +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +- call arscnd (t0) +-c +- msglvl = mnaup2 +-c +-c %-------------------------------------% +-c | Get the machine dependent constant. | +-c %-------------------------------------% +-c +- eps23 = dlamch ('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0 ) +-c +- nev0 = nev +- np0 = np +-c +-c %-------------------------------------% +-c | kplusp is the bound on the largest | +-c | Lanczos factorization built. | +-c | nconv is the current number of | +-c | "converged" eigenvlues. | +-c | iter is the counter on the current | +-c | iteration step. | +-c %-------------------------------------% +-c +- kplusp = nev + np +- nconv = 0 +- iter = 0 +-c +-c %---------------------------------------% +-c | Set flags for computing the first NEV | +-c | steps of the Arnoldi factorization. | +-c %---------------------------------------% +-c +- getv0 = .true. +- update = .false. +- ushift = .false. +- cnorm = .false. +-c +- if (info .ne. 0) then +-c +-c %--------------------------------------------% +-c | User provides the initial residual vector. | +-c %--------------------------------------------% +-c +- initv = .true. +- info = 0 +- else +- initv = .false. +- end if +- end if +-c +-c %---------------------------------------------% +-c | Get a possibly random starting vector and | +-c | force it into the range of the operator OP. | +-c %---------------------------------------------% +-c +- 10 continue +-c +- if (getv0) then +- call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, +- & ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (rnorm .eq. zero) then +-c +-c %-----------------------------------------% +-c | The initial vector is zero. Error exit. | +-c %-----------------------------------------% +-c +- info = -9 +- go to 1100 +- end if +- getv0 = .false. +- ido = 0 +- end if +-c +-c %-----------------------------------% +-c | Back from reverse communication : | +-c | continue with update step | +-c %-----------------------------------% +-c +- if (update) go to 20 +-c +-c %-------------------------------------------% +-c | Back from computing user specified shifts | +-c %-------------------------------------------% +-c +- if (ushift) go to 50 +-c +-c %-------------------------------------% +-c | Back from computing residual norm | +-c | at the end of the current iteration | +-c %-------------------------------------% +-c +- if (cnorm) go to 100 +-c +-c %----------------------------------------------------------% +-c | Compute the first NEV steps of the Arnoldi factorization | +-c %----------------------------------------------------------% +-c +- call dnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, +- & h, ldh, ipntr, workd, info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +-c +-c %--------------------------------------------------------------% +-c | | +-c | M A I N ARNOLDI I T E R A T I O N L O O P | +-c | Each iteration implicitly restarts the Arnoldi | +-c | factorization in place. | +-c | | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- iter = iter + 1 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [iter], ndigit, +- & '_naup2: **** Start of major iteration number ****') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c | Adjust NP since NEV might have been updated by last call | +-c | to the shift application routine dnapps . | +-c %-----------------------------------------------------------% +-c +- np = kplusp - nev +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [nev], ndigit, +- & '_naup2: The length of the current Arnoldi factorization') +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: Extend the Arnoldi factorization by') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c %-----------------------------------------------------------% +-c +- ido = 0 +- 20 continue +- update = .true. +-c +- call dnaitr (ido , bmat, n , nev, np , mode , resid, +- & rnorm, v , ldv, h , ldh, ipntr, workd, +- & info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +- update = .false. +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_naup2: Corresponding B-norm of the residual') +- end if +-c +-c %--------------------------------------------------------% +-c | Compute the eigenvalues and corresponding error bounds | +-c | of the current upper Hessenberg matrix. | +-c %--------------------------------------------------------% +-c +- call dneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, +- & q, ldq, workl, ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 1200 +- end if +-c +-c %----------------------------------------------------% +-c | Make a copy of eigenvalues and corresponding error | +-c | bounds obtained from dneigh . | +-c %----------------------------------------------------% +-c +- call dcopy (kplusp, ritzr, 1, workl(kplusp**2+1), 1) +- call dcopy (kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) +- call dcopy (kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The wanted part of the spectrum and corresponding | +-c | error bounds are in the last NEV loc. of RITZR, | +-c | RITZI and BOUNDS respectively. The variables NEV | +-c | and NP may be updated if the NEV-th wanted Ritz | +-c | value has a non zero imaginary part. In this case | +-c | NEV is increased by one and NP decreased by one. | +-c | NOTE: The last two arguments of dngets are no | +-c | longer used as of version 2.1. | +-c %---------------------------------------------------% +-c +- nev = nev0 +- np = np0 +- numcnv = nev +- call dngets (ishift, which, nev, np, ritzr, ritzi, +- & bounds, workl, workl(np+1)) +- if (nev .eq. nev0+1) numcnv = nev0+1 +-c +-c %-------------------% +-c | Convergence test. | +-c %-------------------% +-c +- call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1) +- call dnconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), +- & tol, nconv) +-c +- if (msglvl .gt. 2) then +- kp(1) = nev +- kp(2) = np +- kp(3) = numcnv +- kp(4) = nconv +- call ivout (logfil, 4, kp, ndigit, +- & '_naup2: NEV, NP, NUMCNV, NCONV are') +- call dvout (logfil, kplusp, ritzr, ndigit, +- & '_naup2: Real part of the eigenvalues of H') +- call dvout (logfil, kplusp, ritzi, ndigit, +- & '_naup2: Imaginary part of the eigenvalues of H') +- call dvout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Ritz estimates of the current NCV Ritz values') +- end if +-c +-c %---------------------------------------------------------% +-c | Count the number of unwanted Ritz values that have zero | +-c | Ritz estimates. If any Ritz estimates are equal to zero | +-c | then a leading block of H of order equal to at least | +-c | the number of Ritz values with zero Ritz estimates has | +-c | split off. None of these Ritz values may be removed by | +-c | shifting. Decrease NP the number of shifts to apply. If | +-c | no shifts may be applied, then prepare to exit | +-c %---------------------------------------------------------% +-c +- nptemp = np +- do 30 j=1, nptemp +- if (bounds(j) .eq. zero) then +- np = np - 1 +- nev = nev + 1 +- end if +- 30 continue +-c +- if ( (nconv .ge. numcnv) .or. +- & (iter .gt. mxiter) .or. +- & (np .eq. 0) ) then +-c +- if (msglvl .gt. 4) then +- call dvout (logfil, kplusp, workl(kplusp**2+1), ndigit, +- & '_naup2: Real part of the eig computed by _neigh:') +- call dvout (logfil, kplusp, workl(kplusp**2+kplusp+1), +- & ndigit, +- & '_naup2: Imag part of the eig computed by _neigh:') +- call dvout (logfil, kplusp, workl(kplusp**2+kplusp*2+1), +- & ndigit, +- & '_naup2: Ritz eistmates computed by _neigh:') +- end if +-c +-c %------------------------------------------------% +-c | Prepare to exit. Put the converged Ritz values | +-c | and corresponding bounds in RITZ(1:NCONV) and | +-c | BOUNDS(1:NCONV) respectively. Then sort. Be | +-c | careful when NCONV > NP | +-c %------------------------------------------------% +-c +-c %------------------------------------------% +-c | Use h( 3,1 ) as storage to communicate | +-c | rnorm to _neupd if needed | +-c %------------------------------------------% +- +- h(3,1) = rnorm +-c +-c %----------------------------------------------% +-c | To be consistent with dngets , we first do a | +-c | pre-processing sort in order to keep complex | +-c | conjugate pairs together. This is similar | +-c | to the pre-processing sort used in dngets | +-c | except that the sort is done in the opposite | +-c | order. | +-c %----------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SR' +- if (which .eq. 'SM') wprime = 'LR' +- if (which .eq. 'LR') wprime = 'SM' +- if (which .eq. 'SR') wprime = 'LM' +- if (which .eq. 'LI') wprime = 'SM' +- if (which .eq. 'SI') wprime = 'LM' +-c +- call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) +-c +-c %----------------------------------------------% +-c | Now sort Ritz values so that converged Ritz | +-c | values appear within the first NEV locations | +-c | of ritzr, ritzi and bounds, and the most | +-c | desired one appears at the front. | +-c %----------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SM' +- if (which .eq. 'SM') wprime = 'LM' +- if (which .eq. 'LR') wprime = 'SR' +- if (which .eq. 'SR') wprime = 'LR' +- if (which .eq. 'LI') wprime = 'SI' +- if (which .eq. 'SI') wprime = 'LI' +-c +- call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) +-c +-c %--------------------------------------------------% +-c | Scale the Ritz estimate of each Ritz value | +-c | by 1 / max(eps23,magnitude of the Ritz value). | +-c %--------------------------------------------------% +-c +- do 35 j = 1, numcnv +- temp = max(eps23,dlapy2 (ritzr(j), +- & ritzi(j))) +- bounds(j) = bounds(j)/temp +- 35 continue +-c +-c %----------------------------------------------------% +-c | Sort the Ritz values according to the scaled Ritz | +-c | estimates. This will push all the converged ones | +-c | towards the front of ritzr, ritzi, bounds | +-c | (in the case when NCONV < NEV.) | +-c %----------------------------------------------------% +-c +- wprime = 'LR' +- call dsortc (wprime, .true., numcnv, bounds, ritzr, ritzi) +-c +-c %----------------------------------------------% +-c | Scale the Ritz estimate back to its original | +-c | value. | +-c %----------------------------------------------% +-c +- do 40 j = 1, numcnv +- temp = max(eps23, dlapy2 (ritzr(j), +- & ritzi(j))) +- bounds(j) = bounds(j)*temp +- 40 continue +-c +-c %------------------------------------------------% +-c | Sort the converged Ritz values again so that | +-c | the "threshold" value appears at the front of | +-c | ritzr, ritzi and bound. | +-c %------------------------------------------------% +-c +- call dsortc (which, .true., nconv, ritzr, ritzi, bounds) +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, kplusp, ritzr, ndigit, +- & '_naup2: Sorted real part of the eigenvalues') +- call dvout (logfil, kplusp, ritzi, ndigit, +- & '_naup2: Sorted imaginary part of the eigenvalues') +- call dvout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Sorted ritz estimates.') +- end if +-c +-c %------------------------------------% +-c | Max iterations have been exceeded. | +-c %------------------------------------% +-c +- if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 +-c +-c %---------------------% +-c | No shifts to apply. | +-c %---------------------% +-c +- if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 +-c +- np = nconv +- go to 1100 +-c +- else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then +-c +-c %-------------------------------------------------% +-c | Do not have all the requested eigenvalues yet. | +-c | To prevent possible stagnation, adjust the size | +-c | of NEV. | +-c %-------------------------------------------------% +-c +- nevbef = nev +- nev = nev + min(nconv, np/2) +- if (nev .eq. 1 .and. kplusp .ge. 6) then +- nev = kplusp / 2 +- else if (nev .eq. 1 .and. kplusp .gt. 3) then +- nev = 2 +- end if +-c %---- Scipy fix ------------------------------------------------ +-c | We must keep nev below this value, as otherwise we can get +-c | np == 0 (note that dngets below can bump nev by 1). If np == 0, +-c | the next call to `dnaitr` will write out-of-bounds. +-c | +- if (nev .gt. kplusp - 2) then +- nev = kplusp - 2 +- end if +-c | +-c %---- Scipy fix end -------------------------------------------- +-c +- np = kplusp - nev +-c +-c %---------------------------------------% +-c | If the size of NEV was just increased | +-c | resort the eigenvalues. | +-c %---------------------------------------% +-c +- if (nevbef .lt. nev) +- & call dngets (ishift, which, nev, np, ritzr, ritzi, +- & bounds, workl, workl(np+1)) +-c +- end if +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [nconv], ndigit, +- & '_naup2: no. of "converged" Ritz values at this iter.') +- if (msglvl .gt. 1) then +- kp(1) = nev +- kp(2) = np +- call ivout (logfil, 2, kp, ndigit, +- & '_naup2: NEV and NP are') +- call dvout (logfil, nev, ritzr(np+1), ndigit, +- & '_naup2: "wanted" Ritz values -- real part') +- call dvout (logfil, nev, ritzi(np+1), ndigit, +- & '_naup2: "wanted" Ritz values -- imag part') +- call dvout (logfil, nev, bounds(np+1), ndigit, +- & '_naup2: Ritz estimates of the "wanted" values ') +- end if +- end if +-c +- if (ishift .eq. 0) then +-c +-c %-------------------------------------------------------% +-c | User specified shifts: reverse communication to | +-c | compute the shifts. They are returned in the first | +-c | 2*NP locations of WORKL. | +-c %-------------------------------------------------------% +-c +- ushift = .true. +- ido = 3 +- go to 9000 +- end if +-c +- 50 continue +-c +-c %------------------------------------% +-c | Back from reverse communication; | +-c | User specified shifts are returned | +-c | in WORKL(1:2*NP) | +-c %------------------------------------% +-c +- ushift = .false. +-c +- if ( ishift .eq. 0 ) then +-c +-c %----------------------------------% +-c | Move the NP shifts from WORKL to | +-c | RITZR, RITZI to free up WORKL | +-c | for non-exact shift case. | +-c %----------------------------------% +-c +- call dcopy (np, workl, 1, ritzr, 1) +- call dcopy (np, workl(np+1), 1, ritzi, 1) +- end if +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: The number of shifts to apply ') +- call dvout (logfil, np, ritzr, ndigit, +- & '_naup2: Real part of the shifts') +- call dvout (logfil, np, ritzi, ndigit, +- & '_naup2: Imaginary part of the shifts') +- if ( ishift .eq. 1 ) +- & call dvout (logfil, np, bounds, ndigit, +- & '_naup2: Ritz estimates of the shifts') +- end if +-c +-c %---------------------------------------------------------% +-c | Apply the NP implicit shifts by QR bulge chasing. | +-c | Each shift is applied to the whole upper Hessenberg | +-c | matrix H. | +-c | The first 2*N locations of WORKD are used as workspace. | +-c %---------------------------------------------------------% +-c +- call dnapps (n, nev, np, ritzr, ritzi, v, ldv, +- & h, ldh, resid, q, ldq, workl, workd) +-c +-c %---------------------------------------------% +-c | Compute the B-norm of the updated residual. | +-c | Keep B*RESID in WORKD(1:N) to be used in | +-c | the first step of the next call to dnaitr . | +-c %---------------------------------------------% +-c +- cnorm = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*RESID | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd, 1) +- end if +-c +- 100 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(1:N) := B*RESID | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- rnorm = ddot (n, resid, 1, workd, 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = dnrm2 (n, resid, 1) +- end if +- cnorm = .false. +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_naup2: B-norm of residual for compressed factorization') +- call dmout (logfil, nev, nev, h, ldh, ndigit, +- & '_naup2: Compressed upper Hessenberg matrix H') +- end if +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 1100 continue +-c +- mxiter = iter +- nev = numcnv +-c +- 1200 continue +- ido = 99 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- call arscnd (t1) +- tnaup2 = t1 - t0 +-c +- 9000 continue +-c +-c %---------------% +-c | End of dnaup2 | +-c %---------------% +-c +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaupd.f +deleted file mode 100644 +index 0b4cbb0d84..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnaupd.f ++++ /dev/null +@@ -1,693 +0,0 @@ +-c\BeginDoc +-c +-c\Name: dnaupd +-c +-c\Description: +-c Reverse communication interface for the Implicitly Restarted Arnoldi +-c iteration. This subroutine computes approximations to a few eigenpairs +-c of a linear operator "OP" with respect to a semi-inner product defined by +-c a symmetric positive semi-definite real matrix B. B may be the identity +-c matrix. NOTE: If the linear operator "OP" is real and symmetric +-c with respect to the real positive semi-definite symmetric matrix B, +-c i.e. B*OP = (OP`)*B, then subroutine dsaupd should be used instead. +-c +-c The computed approximate eigenvalues are called Ritz values and +-c the corresponding approximate eigenvectors are called Ritz vectors. +-c +-c dnaupd is usually called iteratively to solve one of the +-c following problems: +-c +-c Mode 1: A*x = lambda*x. +-c ===> OP = A and B = I. +-c +-c Mode 2: A*x = lambda*M*x, M symmetric positive definite +-c ===> OP = inv[M]*A and B = M. +-c ===> (If M can be factored see remark 3 below) +-c +-c Mode 3: A*x = lambda*M*x, M symmetric semi-definite +-c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. +-c ===> shift-and-invert mode (in real arithmetic) +-c If OP*x = amu*x, then +-c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. +-c Note: If sigma is real, i.e. imaginary part of sigma is zero; +-c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M +-c amu == 1/(lambda-sigma). +-c +-c Mode 4: A*x = lambda*M*x, M symmetric semi-definite +-c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. +-c ===> shift-and-invert mode (in real arithmetic) +-c If OP*x = amu*x, then +-c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. +-c +-c Both mode 3 and 4 give the same enhancement to eigenvalues close to +-c the (complex) shift sigma. However, as lambda goes to infinity, +-c the operator OP in mode 4 dampens the eigenvalues more strongly than +-c does OP defined in mode 3. +-c +-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +-c should be accomplished either by a direct method +-c using a sparse matrix factorization and solving +-c +-c [A - sigma*M]*w = v or M*w = v, +-c +-c or through an iterative method for solving these +-c systems. If an iterative method is used, the +-c convergence test must be more stringent than +-c the accuracy requirements for the eigenvalue +-c approximations. +-c +-c\Usage: +-c call dnaupd +-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +-c IPNTR, WORKD, WORKL, LWORKL, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to dnaupd . IDO will be set internally to +-c indicate the type of operation to be performed. Control is +-c then given back to the calling routine which has the +-c responsibility to carry out the requested operation and call +-c dnaupd with the result. The operand is given in +-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c In mode 3 and 4, the vector B * X is already +-c available in WORKD(ipntr(3)). It does not +-c need to be recomputed in forming OP * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 3: compute the IPARAM(8) real and imaginary parts +-c of the shifts where INPTR(14) is the pointer +-c into WORKL for placing the shifts. See Remark +-c 5 below. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. +-c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x +-c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c WHICH Character*2. (INPUT) +-c 'LM' -> want the NEV eigenvalues of largest magnitude. +-c 'SM' -> want the NEV eigenvalues of smallest magnitude. +-c 'LR' -> want the NEV eigenvalues of largest real part. +-c 'SR' -> want the NEV eigenvalues of smallest real part. +-c 'LI' -> want the NEV eigenvalues of largest imaginary part. +-c 'SI' -> want the NEV eigenvalues of smallest imaginary part. +-c +-c NEV Integer. (INPUT) +-c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. +-c +-c TOL Double precision scalar. (INPUT/OUTPUT) +-c Stopping criterion: the relative accuracy of the Ritz value +-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) +-c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. +-c DEFAULT = DLAMCH ('EPS') (machine precision as computed +-c by the LAPACK auxiliary subroutine DLAMCH ). +-c +-c RESID Double precision array of length N. (INPUT/OUTPUT) +-c On INPUT: +-c If INFO .EQ. 0, a random initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c On OUTPUT: +-c RESID contains the final residual vector. +-c +-c NCV Integer. (INPUT) +-c Number of columns of the matrix V. NCV must satisfy the two +-c inequalities 2 <= NCV-NEV and NCV <= N. +-c This will indicate how many Arnoldi vectors are generated +-c at each iteration. After the startup phase in which NEV +-c Arnoldi vectors are generated, the algorithm generates +-c approximately NCV-NEV Arnoldi vectors at each subsequent update +-c iteration. Most of the cost in generating each Arnoldi vector is +-c in the matrix-vector operation OP*x. +-c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz +-c values are kept together. (See remark 4 below) +-c +-c V Double precision array N by NCV. (OUTPUT) +-c Contains the final set of Arnoldi basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling program. +-c +-c IPARAM Integer array of length 11. (INPUT/OUTPUT) +-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +-c The shifts selected at each iteration are used to restart +-c the Arnoldi iteration in an implicit fashion. +-c ------------------------------------------------------------- +-c ISHIFT = 0: the shifts are provided by the user via +-c reverse communication. The real and imaginary +-c parts of the NCV eigenvalues of the Hessenberg +-c matrix H are returned in the part of the WORKL +-c array corresponding to RITZR and RITZI. See remark +-c 5 below. +-c ISHIFT = 1: exact shifts with respect to the current +-c Hessenberg matrix H. This is equivalent to +-c restarting the iteration with a starting vector +-c that is a linear combination of approximate Schur +-c vectors associated with the "wanted" Ritz values. +-c ------------------------------------------------------------- +-c +-c IPARAM(2) = No longer referenced. +-c +-c IPARAM(3) = MXITER +-c On INPUT: maximum number of Arnoldi update iterations allowed. +-c On OUTPUT: actual number of Arnoldi update iterations taken. +-c +-c IPARAM(4) = NB: blocksize to be used in the recurrence. +-c The code currently works only for NB = 1. +-c +-c IPARAM(5) = NCONV: number of "converged" Ritz values. +-c This represents the number of Ritz values that satisfy +-c the convergence criterion. +-c +-c IPARAM(6) = IUPD +-c No longer referenced. Implicit restarting is ALWAYS used. +-c +-c IPARAM(7) = MODE +-c On INPUT determines what type of eigenproblem is being solved. +-c Must be 1,2,3,4; See under \Description of dnaupd for the +-c four modes available. +-c +-c IPARAM(8) = NP +-c When ido = 3 and the user provides shifts through reverse +-c communication (IPARAM(1)=0), dnaupd returns NP, the number +-c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark +-c 5 below. +-c +-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +-c OUTPUT: NUMOP = total number of OP*x operations, +-c NUMOPB = total number of B*x operations if BMAT='G', +-c NUMREO = total number of steps of re-orthogonalization. +-c +-c IPNTR Integer array of length 14. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD and WORKL +-c arrays for matrices/vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X in WORKD. +-c IPNTR(2): pointer to the current result vector Y in WORKD. +-c IPNTR(3): pointer to the vector B * X in WORKD when used in +-c the shift-and-invert mode. +-c IPNTR(4): pointer to the next available location in WORKL +-c that is untouched by the program. +-c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix +-c H in WORKL. +-c IPNTR(6): pointer to the real part of the ritz value array +-c RITZR in WORKL. +-c IPNTR(7): pointer to the imaginary part of the ritz value array +-c RITZI in WORKL. +-c IPNTR(8): pointer to the Ritz estimates in array WORKL associated +-c with the Ritz values located in RITZR and RITZI in WORKL. +-c +-c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. +-c +-c Note: IPNTR(9:13) is only referenced by dneupd . See Remark 2 below. +-c +-c IPNTR(9): pointer to the real part of the NCV RITZ values of the +-c original system. +-c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of +-c the original system. +-c IPNTR(11): pointer to the NCV corresponding error bounds. +-c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c dneupd if RVEC = .TRUE. See Remark 2 below. +-c ------------------------------------------------------------- +-c +-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration. Upon termination +-c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace +-c associated with the converged Ritz values is desired, see remark +-c 2 below, subroutine dneupd uses this output. +-c See Data Distribution Note below. +-c +-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. See Data Distribution Note below. +-c +-c LWORKL Integer. (INPUT) +-c LWORKL must be at least 3*NCV**2 + 6*NCV. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal exit. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. IPARAM(5) +-c returns the number of wanted converged Ritz values. +-c = 2: No longer an informational error. Deprecated starting +-c with release 2 of ARPACK. +-c = 3: No shifts could be applied during a cycle of the +-c Implicitly restarted Arnoldi iteration. One possibility +-c is to increase the size of NCV relative to NEV. +-c See remark 4 below. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -4: The maximum number of Arnoldi update iteration +-c must be greater than zero. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work array is not sufficient. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3,4. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: IPARAM(1) must be equal to 0 or 1. +-c = -9999: Could not build an Arnoldi factorization. +-c IPARAM(5) returns the size of the current Arnoldi +-c factorization. +-c +-c\Remarks +-c 1. The computed Ritz values are approximate eigenvalues of OP. The +-c selection of WHICH should be made with this in mind when +-c Mode = 3 and 4. After convergence, approximate eigenvalues of the +-c original problem may be obtained with the ARPACK subroutine dneupd . +-c +-c 2. If a basis for the invariant subspace corresponding to the converged Ritz +-c values is needed, the user must call dneupd immediately following +-c completion of dnaupd . This is new starting with release 2 of ARPACK. +-c +-c 3. If M can be factored into a Cholesky factorization M = LL` +-c then Mode = 2 should not be selected. Instead one should use +-c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +-c linear systems should be solved with L and L` rather +-c than computing inverses. After convergence, an approximate +-c eigenvector z of the original problem is recovered by solving +-c L`z = x where x is a Ritz vector of OP. +-c +-c 4. At present there is no a-priori analysis to guide the selection +-c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 2. +-c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of +-c the same type are to be solved, one should experiment with increasing +-c NCV while keeping NEV fixed for a given test problem. This will +-c usually decrease the required number of OP*x operations but it +-c also increases the work and storage required to maintain the orthogonal +-c basis vectors. The optimal "cross-over" with respect to CPU time +-c is problem dependent and must be determined empirically. +-c See Chapter 8 of Reference 2 for further information. +-c +-c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +-c NP = IPARAM(8) real and imaginary parts of the shifts in locations +-c real part imaginary part +-c ----------------------- -------------- +-c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) +-c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) +-c . . +-c . . +-c . . +-c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). +-c +-c Only complex conjugate pairs of shifts may be applied and the pairs +-c must be placed in consecutive locations. The real part of the +-c eigenvalues of the current upper Hessenberg matrix are located in +-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part +-c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered +-c according to the order defined by WHICH. The complex conjugate +-c pairs are kept together and the associated Ritz estimates are located in +-c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). +-c +-c----------------------------------------------------------------------- +-c +-c\Data Distribution Note: +-c +-c Fortran-D syntax: +-c ================ +-c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c decompose d1(n), d2(n,ncv) +-c align resid(i) with d1(i) +-c align v(i,j) with d2(i,j) +-c align workd(i) with d1(i) range (1:n) +-c align workd(i) with d1(i-n) range (n+1:2*n) +-c align workd(i) with d1(i-2*n) range (2*n+1:3*n) +-c distribute d1(block), d2(block,:) +-c replicated workl(lworkl) +-c +-c Cray MPP syntax: +-c =============== +-c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) +-c shared resid(block), v(block,:), workd(block,:) +-c replicated workl(lworkl) +-c +-c CM2/CM5 syntax: +-c ============== +-c +-c----------------------------------------------------------------------- +-c +-c include 'ex-nonsym.doc' +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for +-c Real Matrices", Linear Algebra and its Applications, vol 88/89, +-c pp 575-595, (1987). +-c +-c\Routines called: +-c dnaup2 ARPACK routine that implements the Implicitly Restarted +-c Arnoldi Iteration. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/16/93: Version '1.1' +-c +-c\SCCS Information: @(#) +-c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\Remarks +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dnaupd +- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, +- & ipntr, workd, workl, lworkl, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ldv, lworkl, n, ncv, nev +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- Double precision +- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0 , zero = 0.0D+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, levec, mode, msglvl, mxiter, nb, +- & nev0, next, np, ritzi, ritzr, j +- save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, +- & levec, mode, msglvl, mxiter, nb, nev0, next, +- & np, ritzi, ritzr +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dnaup2 , dvout , ivout, arscnd, dstatn +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlamch +- external dlamch +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call dstatn +- call arscnd (t0) +- msglvl = mnaupd +-c +-c %----------------% +-c | Error checking | +-c %----------------% +-c +- ierr = 0 +- ishift = iparam(1) +-c levec = iparam(2) +- mxiter = iparam(3) +-c nb = iparam(4) +- nb = 1 +-c +-c %--------------------------------------------% +-c | Revision 2 performs only implicit restart. | +-c %--------------------------------------------% +-c +- iupd = 1 +- mode = iparam(7) +-c +- if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev+1 .or. ncv .gt. n) then +- ierr = -3 +- else if (mxiter .le. 0) then +- ierr = -4 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 6*ncv) then +- ierr = -7 +- else if (mode .lt. 1 .or. mode .gt. 4) then +- ierr = -10 +- else if (mode .eq. 1 .and. bmat .eq. 'G') then +- ierr = -11 +- else if (ishift .lt. 0 .or. ishift .gt. 1) then +- ierr = -12 +- end if +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- ido = 99 +- go to 9000 +- end if +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- if (nb .le. 0) nb = 1 +- if (tol .le. zero) tol = dlamch ('EpsMach') +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c | NEV0 is the local variable designating the | +-c | size of the invariant subspace desired. | +-c %----------------------------------------------% +-c +- np = ncv - nev +- nev0 = nev +-c +-c %-----------------------------% +-c | Zero out internal workspace | +-c %-----------------------------% +-c +- do 10 j = 1, 3*ncv**2 + 6*ncv +- workl(j) = zero +- 10 continue +-c +-c %-------------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | +-c | parts of ritz values | +-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | +-c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | +-c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | +-c | The final workspace is needed by subroutine dneigh called | +-c | by dnaup2 . Subroutine dneigh calls LAPACK routines for | +-c | calculating eigenvalues and the last row of the eigenvector | +-c | matrix. | +-c %-------------------------------------------------------------% +-c +- ldh = ncv +- ldq = ncv +- ih = 1 +- ritzr = ih + ldh*ncv +- ritzi = ritzr + ncv +- bounds = ritzi + ncv +- iq = bounds + ncv +- iw = iq + ldq*ncv +- next = iw + ncv**2 + 3*ncv +-c +- ipntr(4) = next +- ipntr(5) = ih +- ipntr(6) = ritzr +- ipntr(7) = ritzi +- ipntr(8) = bounds +- ipntr(14) = iw +-c +- end if +-c +-c %-------------------------------------------------------% +-c | Carry out the Implicitly restarted Arnoldi Iteration. | +-c %-------------------------------------------------------% +-c +- call dnaup2 +- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), +- & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), +- & ipntr, workd, info ) +-c +-c %--------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP or shifts. | +-c %--------------------------------------------------% +-c +- if (ido .eq. 3) iparam(8) = np +- if (ido .ne. 99) go to 9000 +-c +- iparam(3) = mxiter +- iparam(5) = np +- iparam(9) = nopx +- iparam(10) = nbx +- iparam(11) = nrorth +-c +-c %------------------------------------% +-c | Exit if there was an informational | +-c | error within dnaup2 . | +-c %------------------------------------% +-c +- if (info .lt. 0) go to 9000 +- if (info .eq. 2) info = 3 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [mxiter], ndigit, +- & '_naupd: Number of update iterations taken') +- call ivout (logfil, 1, [np], ndigit, +- & '_naupd: Number of wanted "converged" Ritz values') +- call dvout (logfil, np, workl(ritzr), ndigit, +- & '_naupd: Real part of the final Ritz values') +- call dvout (logfil, np, workl(ritzi), ndigit, +- & '_naupd: Imaginary part of the final Ritz values') +- call dvout (logfil, np, workl(bounds), ndigit, +- & '_naupd: Associated Ritz estimates') +- end if +-c +- call arscnd (t1) +- tnaupd = t1 - t0 +-c +- if (msglvl .gt. 0) then +-c +-c %--------------------------------------------------------% +-c | Version Number & Version Date are defined in version.h | +-c %--------------------------------------------------------% +-c +- write (6,1000) +- write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, +- & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, +- & tgetv0, tneigh, tngets, tnapps, tnconv, trvec +- 1000 format (//, +- & 5x, '=============================================',/ +- & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ +- & 5x, '= Version Number: ', ' 2.4' , 21x, ' =',/ +- & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ +- & 5x, '=============================================',/ +- & 5x, '= Summary of timing statistics =',/ +- & 5x, '=============================================',//) +- 1100 format ( +- & 5x, 'Total number update iterations = ', i5,/ +- & 5x, 'Total number of OP*x operations = ', i5,/ +- & 5x, 'Total number of B*x operations = ', i5,/ +- & 5x, 'Total number of reorthogonalization steps = ', i5,/ +- & 5x, 'Total number of iterative refinement steps = ', i5,/ +- & 5x, 'Total number of restart steps = ', i5,/ +- & 5x, 'Total time in user OP*x operation = ', f12.6,/ +- & 5x, 'Total time in user B*x operation = ', f12.6,/ +- & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ +- & 5x, 'Total time in naup2 routine = ', f12.6,/ +- & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ +- & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ +- & 5x, 'Total time in (re)start vector generation = ', f12.6,/ +- & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ +- & 5x, 'Total time in getting the shifts = ', f12.6,/ +- & 5x, 'Total time in applying the shifts = ', f12.6,/ +- & 5x, 'Total time in convergence testing = ', f12.6,/ +- & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of dnaupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnconv.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnconv.f +deleted file mode 100644 +index 4d531f8651..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dnconv.f ++++ /dev/null +@@ -1,146 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dnconv +-c +-c\Description: +-c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. +-c +-c\Usage: +-c call dnconv +-c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Number of Ritz values to check for convergence. +-c +-c RITZR, Double precision arrays of length N. (INPUT) +-c RITZI Real and imaginary parts of the Ritz values to be checked +-c for convergence. +- +-c BOUNDS Double precision array of length N. (INPUT) +-c Ritz estimates for the Ritz values in RITZR and RITZI. +-c +-c TOL Double precision scalar. (INPUT) +-c Desired backward error for a Ritz value to be considered +-c "converged". +-c +-c NCONV Integer scalar. (OUTPUT) +-c Number of "converged" Ritz values. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c dlamch LAPACK routine that determines machine constants. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c 1. xxxx +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dnconv (n, ritzr, ritzi, bounds, tol, nconv) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer n, nconv +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +- +- Double precision +- & ritzr(n), ritzi(n), bounds(n) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i +- Double precision +- & temp, eps23 +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlapy2, dlamch +- external dlapy2, dlamch +- +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------------------------------------% +-c | Convergence test: unlike in the symmetric code, I am not | +-c | using things like refined error bounds and gap condition | +-c | because I don't know the exact equivalent concept. | +-c | | +-c | Instead the i-th Ritz value is considered "converged" when: | +-c | | +-c | bounds(i) .le. ( TOL * | ritz | ) | +-c | | +-c | for some appropriate choice of norm. | +-c %-------------------------------------------------------------% +-c +- call arscnd (t0) +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = dlamch('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0) +-c +- nconv = 0 +- do 20 i = 1, n +- temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) ) +- if (bounds(i) .le. tol*temp) nconv = nconv + 1 +- 20 continue +-c +- call arscnd (t1) +- tnconv = tnconv + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of dnconv | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneigh.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneigh.f +deleted file mode 100644 +index 3c49e32bf0..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneigh.f ++++ /dev/null +@@ -1,318 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dneigh +-c +-c\Description: +-c Compute the eigenvalues of the current upper Hessenberg matrix +-c and the corresponding Ritz estimates given the current residual norm. +-c +-c\Usage: +-c call dneigh +-c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) +-c +-c\Arguments +-c RNORM Double precision scalar. (INPUT) +-c Residual norm corresponding to the current upper Hessenberg +-c matrix H. +-c +-c N Integer. (INPUT) +-c Size of the matrix H. +-c +-c H Double precision N by N array. (INPUT) +-c H contains the current upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZR, Double precision arrays of length N. (OUTPUT) +-c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real +-c (respectively imaginary) parts of the eigenvalues of H. +-c +-c BOUNDS Double precision array of length N. (OUTPUT) +-c On output, BOUNDS contains the Ritz estimates associated with +-c the eigenvalues RITZR and RITZI. This is equal to RNORM +-c times the last components of the eigenvectors corresponding +-c to the eigenvalues in RITZR and RITZI. +-c +-c Q Double precision N by N array. (WORKSPACE) +-c Workspace needed to store the eigenvectors of H. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. This is needed to keep the full Schur form +-c of H and also in the calculation of the eigenvectors of H. +-c +-c IERR Integer. (OUTPUT) +-c Error exit flag from dlahqr or dtrevc. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c dlahqr LAPACK routine to compute the real Schur form of an +-c upper Hessenberg matrix and last row of the Schur vectors. +-c arscnd ARPACK utility routine for timing. +-c dmout ARPACK utility routine that prints matrices +-c dvout ARPACK utility routine that prints vectors. +-c dlacpy LAPACK matrix copy routine. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c dtrevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper quasi-triangular form +-c dgemv Level 2 BLAS routine for matrix vector multiplication. +-c dcopy Level 1 BLAS that copies one vector to another . +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c dscal Level 1 BLAS that scales a vector. +-c +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, +- & q, ldq, workl, ierr) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer ierr, n, ldh, ldq +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), +- & workl(n*(n+3)) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical select(1) +- integer i, iconj, msglvl +- Double precision +- & temp, vl(1) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy, dlacpy, dlahqr, dtrevc, dvout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlapy2, dnrm2 +- external dlapy2, dnrm2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mneigh +-c +- if (msglvl .gt. 2) then +- call dmout (logfil, n, n, h, ldh, ndigit, +- & '_neigh: Entering upper Hessenberg matrix H ') +- end if +-c +-c %-----------------------------------------------------------% +-c | 1. Compute the eigenvalues, the last components of the | +-c | corresponding Schur vectors and the full Schur form T | +-c | of the current upper Hessenberg matrix H. | +-c | dlahqr returns the full Schur form of H in WORKL(1:N**2) | +-c | and the last components of the Schur vectors in BOUNDS. | +-c %-----------------------------------------------------------% +-c +- call dlacpy ('All', n, n, h, ldh, workl, n) +- do 5 j = 1, n-1 +- bounds(j) = zero +- 5 continue +- bounds(n) = 1 +- call dlahqr(.true., .true., n, 1, n, workl, n, ritzr, ritzi, 1, 1, +- & bounds, 1, ierr) +- if (ierr .ne. 0) go to 9000 +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, n, bounds, ndigit, +- & '_neigh: last row of the Schur matrix for H') +- end if +-c +-c %-----------------------------------------------------------% +-c | 2. Compute the eigenvectors of the full Schur form T and | +-c | apply the last components of the Schur vectors to get | +-c | the last components of the corresponding eigenvectors. | +-c | Remember that if the i-th and (i+1)-st eigenvalues are | +-c | complex conjugate pairs, then the real & imaginary part | +-c | of the eigenvector components are split across adjacent | +-c | columns of Q. | +-c %-----------------------------------------------------------% +-c +- call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, +- & n, n, workl(n*n+1), ierr) +-c +- if (ierr .ne. 0) go to 9000 +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | euclidean norms are all one. LAPACK subroutine | +-c | dtrevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1; here the magnitude of a complex | +-c | number (x,y) is taken to be |x| + |y|. | +-c %------------------------------------------------% +-c +- iconj = 0 +- do 10 i=1, n +- if ( abs( ritzi(i) ) .le. zero ) then +-c +-c %----------------------% +-c | Real eigenvalue case | +-c %----------------------% +-c +- temp = dnrm2( n, q(1,i), 1 ) +- call dscal ( n, one / temp, q(1,i), 1 ) +- else +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c | columns, we further normalize by the | +-c | square root of two. | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- temp = dlapy2( dnrm2( n, q(1,i), 1 ), +- & dnrm2( n, q(1,i+1), 1 ) ) +- call dscal ( n, one / temp, q(1,i), 1 ) +- call dscal ( n, one / temp, q(1,i+1), 1 ) +- iconj = 1 +- else +- iconj = 0 +- end if +- end if +- 10 continue +-c +- call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, n, workl, ndigit, +- & '_neigh: Last row of the eigenvector matrix for H') +- end if +-c +-c %----------------------------% +-c | Compute the Ritz estimates | +-c %----------------------------% +-c +- iconj = 0 +- do 20 i = 1, n +- if ( abs( ritzi(i) ) .le. zero ) then +-c +-c %----------------------% +-c | Real eigenvalue case | +-c %----------------------% +-c +- bounds(i) = rnorm * abs( workl(i) ) +- else +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c | columns, we need to take the magnitude | +-c | of the last components of the two vectors | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) ) +- bounds(i+1) = bounds(i) +- iconj = 1 +- else +- iconj = 0 +- end if +- end if +- 20 continue +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, n, ritzr, ndigit, +- & '_neigh: Real part of the eigenvalues of H') +- call dvout (logfil, n, ritzi, ndigit, +- & '_neigh: Imaginary part of the eigenvalues of H') +- call dvout (logfil, n, bounds, ndigit, +- & '_neigh: Ritz estimates for the eigenvalues of H') +- end if +-c +- call arscnd (t1) +- tneigh = tneigh + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dneigh | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneupd.f +deleted file mode 100644 +index 860ceb856c..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dneupd.f ++++ /dev/null +@@ -1,1071 +0,0 @@ +-c\BeginDoc +-c +-c\Name: dneupd +-c +-c\Description: +-c +-c This subroutine returns the converged approximations to eigenvalues +-c of A*z = lambda*B*z and (optionally): +-c +-c (1) The corresponding approximate eigenvectors; +-c +-c (2) An orthonormal basis for the associated approximate +-c invariant subspace; +-c +-c (3) Both. +-c +-c There is negligible additional cost to obtain eigenvectors. An orthonormal +-c basis is always computed. There is an additional storage cost of n*nev +-c if both are requested (in this case a separate array Z must be supplied). +-c +-c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z +-c are derived from approximate eigenvalues and eigenvectors of +-c of the linear operator OP prescribed by the MODE selection in the +-c call to DNAUPD . DNAUPD must be called before this routine is called. +-c These approximate eigenvalues and vectors are commonly called Ritz +-c values and Ritz vectors respectively. They are referred to as such +-c in the comments that follow. The computed orthonormal basis for the +-c invariant subspace corresponding to these Ritz values is referred to as a +-c Schur basis. +-c +-c See documentation in the header of the subroutine DNAUPD for +-c definition of OP as well as other terms and the relation of computed +-c Ritz values and Ritz vectors of OP with respect to the given problem +-c A*z = lambda*B*z. For a brief description, see definitions of +-c IPARAM(7), MODE and WHICH in the documentation of DNAUPD . +-c +-c\Usage: +-c call dneupd +-c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, +-c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, +-c LWORKL, INFO ) +-c +-c\Arguments: +-c RVEC LOGICAL (INPUT) +-c Specifies whether a basis for the invariant subspace corresponding +-c to the converged Ritz value approximations for the eigenproblem +-c A*z = lambda*B*z is computed. +-c +-c RVEC = .FALSE. Compute Ritz values only. +-c +-c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. +-c See Remarks below. +-c +-c HOWMNY Character*1 (INPUT) +-c Specifies the form of the basis for the invariant subspace +-c corresponding to the converged Ritz values that is to be computed. +-c +-c = 'A': Compute NEV Ritz vectors; +-c = 'P': Compute NEV Schur vectors; +-c = 'S': compute some of the Ritz vectors, specified +-c by the logical array SELECT. +-c +-c SELECT Logical array of dimension NCV. (INPUT) +-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +-c computed. To select the Ritz vector corresponding to a +-c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. +-c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. +-c +-c DR Double precision array of dimension NEV+1. (OUTPUT) +-c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains +-c the real part of the Ritz approximations to the eigenvalues of +-c A*z = lambda*B*z. +-c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: +-c DR contains the real part of the Ritz values of OP computed by +-c DNAUPD . A further computation must be performed by the user +-c to transform the Ritz values computed for OP by DNAUPD to those +-c of the original system A*z = lambda*B*z. See remark 3 below. +-c +-c DI Double precision array of dimension NEV+1. (OUTPUT) +-c On exit, DI contains the imaginary part of the Ritz value +-c approximations to the eigenvalues of A*z = lambda*B*z associated +-c with DR. +-c +-c NOTE: When Ritz values are complex, they will come in complex +-c conjugate pairs. If eigenvectors are requested, the +-c corresponding Ritz vectors will also come in conjugate +-c pairs and the real and imaginary parts of these are +-c represented in two consecutive columns of the array Z +-c (see below). +-c +-c Z Double precision N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) +-c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of +-c Z represent approximate eigenvectors (Ritz vectors) corresponding +-c to the NCONV=IPARAM(5) Ritz values for eigensystem +-c A*z = lambda*B*z. +-c +-c The complex Ritz vector associated with the Ritz value +-c with positive imaginary part is stored in two consecutive +-c columns. The first column holds the real part of the Ritz +-c vector and the second column holds the imaginary part. The +-c Ritz vector associated with the Ritz value with negative +-c imaginary part is simply the complex conjugate of the Ritz vector +-c associated with the positive imaginary part. +-c +-c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. +-c +-c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, +-c the array Z may be set equal to first NEV+1 columns of the Arnoldi +-c basis array V computed by DNAUPD . In this case the Arnoldi basis +-c will be destroyed and overwritten with the eigenvector basis. +-c +-c LDZ Integer. (INPUT) +-c The leading dimension of the array Z. If Ritz vectors are +-c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. +-c +-c SIGMAR Double precision (INPUT) +-c If IPARAM(7) = 3 or 4, represents the real part of the shift. +-c Not referenced if IPARAM(7) = 1 or 2. +-c +-c SIGMAI Double precision (INPUT) +-c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. +-c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. +-c +-c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE) +-c +-c **** The remaining arguments MUST be the same as for the **** +-c **** call to DNAUPD that was just completed. **** +-c +-c NOTE: The remaining arguments +-c +-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +-c WORKD, WORKL, LWORKL, INFO +-c +-c must be passed directly to DNEUPD following the last call +-c to DNAUPD . These arguments MUST NOT BE MODIFIED between +-c the the last call to DNAUPD and the call to DNEUPD . +-c +-c Three of these parameters (V, WORKL, INFO) are also output parameters: +-c +-c V Double precision N by NCV array. (INPUT/OUTPUT) +-c +-c Upon INPUT: the NCV columns of V contain the Arnoldi basis +-c vectors for OP as constructed by DNAUPD . +-c +-c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns +-c contain approximate Schur vectors that span the +-c desired invariant subspace. See Remark 2 below. +-c +-c NOTE: If the array Z has been set equal to first NEV+1 columns +-c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the +-c Arnoldi basis held by V has been overwritten by the desired +-c Ritz vectors. If a separate array Z has been passed then +-c the first NCONV=IPARAM(5) columns of V will contain approximate +-c Schur vectors that span the desired invariant subspace. +-c +-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +-c WORKL(1:ncv*ncv+3*ncv) contains information obtained in +-c dnaupd . They are not changed by dneupd . +-c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the +-c real and imaginary part of the untransformed Ritz values, +-c the upper quasi-triangular matrix for H, and the +-c associated matrix representation of the invariant subspace for H. +-c +-c Note: IPNTR(9:13) contains the pointer into WORKL for addresses +-c of the above information computed by dneupd . +-c ------------------------------------------------------------- +-c IPNTR(9): pointer to the real part of the NCV RITZ values of the +-c original system. +-c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of +-c the original system. +-c IPNTR(11): pointer to the NCV corresponding error bounds. +-c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c dneupd if RVEC = .TRUE. See Remark 2 below. +-c ------------------------------------------------------------- +-c +-c INFO Integer. (OUTPUT) +-c Error flag on output. +-c +-c = 0: Normal exit. +-c +-c = 1: The Schur form computed by LAPACK routine dlahqr +-c could not be reordered by LAPACK routine dtrsen . +-c Re-enter subroutine dneupd with IPARAM(5)=NCV and +-c increase the size of the arrays DR and DI to have +-c dimension at least dimension NCV and allocate at least NCV +-c columns for Z. NOTE: Not necessary if Z and V share +-c the same space. Please notify the authors if this error +-c occurs. +-c +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work WORKL array is not sufficient. +-c = -8: Error return from calculation of a real Schur form. +-c Informational error from LAPACK routine dlahqr . +-c = -9: Error return from calculation of eigenvectors. +-c Informational error from LAPACK routine dtrevc . +-c = -10: IPARAM(7) must be 1,2,3,4. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: HOWMNY = 'S' not yet implemented +-c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. +-c = -14: DNAUPD did not find any eigenvalues to sufficient +-c accuracy. +-c = -15: DNEUPD got a different count of the number of converged +-c Ritz values than DNAUPD got. This indicates the user +-c probably made an error in passing data from DNAUPD to +-c DNEUPD or that the data was modified before entering +-c DNEUPD +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for +-c Real Matrices", Linear Algebra and its Applications, vol 88/89, +-c pp 575-595, (1987). +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c dmout ARPACK utility routine that prints matrices +-c dvout ARPACK utility routine that prints vectors. +-c dgeqr2 LAPACK routine that computes the QR factorization of +-c a matrix. +-c dlacpy LAPACK matrix copy routine. +-c dlahqr LAPACK routine to compute the real Schur form of an +-c upper Hessenberg matrix. +-c dlamch LAPACK routine that determines machine constants. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c dlaset LAPACK matrix initialization routine. +-c dorm2r LAPACK routine that applies an orthogonal matrix in +-c factored form. +-c dtrevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper quasi-triangular form. +-c dtrsen LAPACK routine that re-orders the Schur form. +-c dtrmm Level 3 BLAS matrix times an upper triangular matrix. +-c dger Level 2 BLAS rank one update to a matrix. +-c dcopy Level 1 BLAS that copies one vector to another . +-c ddot Level 1 BLAS that computes the scalar product of two vectors. +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c dscal Level 1 BLAS that scales a vector. +-c +-c\Remarks +-c +-c 1. Currently only HOWMNY = 'A' and 'P' are implemented. +-c +-c Let trans(X) denote the transpose of X. +-c +-c 2. Schur vectors are an orthogonal representation for the basis of +-c Ritz vectors. Thus, their numerical properties are often superior. +-c If RVEC = .TRUE. then the relationship +-c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and +-c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately +-c satisfied. Here T is the leading submatrix of order IPARAM(5) of the +-c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, +-c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; +-c each 2-by-2 diagonal block has its diagonal elements equal and its +-c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 +-c diagonal block is a complex conjugate pair of Ritz values. The real +-c Ritz values are stored on the diagonal of T. +-c +-c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must +-c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz +-c values computed by DNAUPD for OP to those of A*z = lambda*B*z. +-c Set RVEC = .true. and HOWMNY = 'A', and +-c compute +-c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. +-c If DI(I) is not equal to zero and DI(I+1) = - D(I), +-c then the desired real and imaginary parts of the Ritz value are +-c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), +-c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), +-c respectively. +-c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and +-c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper +-c quasi-triangular matrix of order IPARAM(5) is computed. See remark +-c 2 above. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +- subroutine dneupd (rvec , howmny, select, dr , di, +- & z , ldz , sigmar, sigmai, workev, +- & bmat , n , which , nev , tol, +- & resid, ncv , v , ldv , iparam, +- & ipntr, workd , workl , lworkl, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat, howmny, which*2 +- logical rvec +- integer info, ldz, ldv, lworkl, n, ncv, nev +- Double precision +- & sigmar, sigmai, tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- logical select(ncv) +- Double precision +- & dr(nev+1) , di(nev+1), resid(n) , +- & v(ldv,ncv) , z(ldz,*) , workd(3*n), +- & workl(lworkl), workev(3*ncv) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0 , zero = 0.0D+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character type*6 +- integer bounds, ierr , ih , ihbds , +- & iheigr, iheigi, iconj , nconv , +- & invsub, iuptri, iwev , iwork(1), +- & j , k , ldh , ldq , +- & mode , msglvl, outncv, ritzr , +- & ritzi , wri , wrr , irr , +- & iri , ibd , ishift, numcnv , +- & np , jj , nconv2 +- logical reord +- Double precision +- & conds , rnorm, sep , temp, +- & vl(1,1), temp1, eps23 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy , dger , dgeqr2 , dlacpy , +- & dlahqr , dlaset , dmout , dorm2r , +- & dtrevc , dtrmm , dtrsen , dscal , +- & dvout , ivout +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlapy2 , dnrm2 , dlamch , ddot +- external dlapy2 , dnrm2 , dlamch , ddot +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs, min, sqrt +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- msglvl = mneupd +- mode = iparam(7) +- nconv = iparam(5) +- info = 0 +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = dlamch ('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0 ) +-c +-c %--------------% +-c | Quick return | +-c %--------------% +-c +- ierr = 0 +-c +- if (nconv .le. 0) then +- ierr = -14 +- else if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev+1 .or. ncv .gt. n) then +- ierr = -3 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 6*ncv) then +- ierr = -7 +- else if ( (howmny .ne. 'A' .and. +- & howmny .ne. 'P' .and. +- & howmny .ne. 'S') .and. rvec ) then +- ierr = -13 +- else if (howmny .eq. 'S' ) then +- ierr = -12 +- end if +-c +- if (mode .eq. 1 .or. mode .eq. 2) then +- type = 'REGULR' +- else if (mode .eq. 3 .and. sigmai .eq. zero) then +- type = 'SHIFTI' +- else if (mode .eq. 3 ) then +- type = 'REALPT' +- else if (mode .eq. 4 ) then +- type = 'IMAGPT' +- else +- ierr = -10 +- end if +- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | +-c | parts of ritz values | +-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | +-c %--------------------------------------------------------% +-c +-c %-----------------------------------------------------------% +-c | The following is used and set by DNEUPD . | +-c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | +-c | real part of the Ritz values. | +-c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | +-c | imaginary part of the Ritz values. | +-c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | +-c | error bounds of the Ritz values | +-c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | +-c | quasi-triangular matrix for H | +-c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | +-c | associated matrix representation of the invariant | +-c | subspace for H. | +-c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | +-c %-----------------------------------------------------------% +-c +- ih = ipntr(5) +- ritzr = ipntr(6) +- ritzi = ipntr(7) +- bounds = ipntr(8) +- ldh = ncv +- ldq = ncv +- iheigr = bounds + ldh +- iheigi = iheigr + ldh +- ihbds = iheigi + ldh +- iuptri = ihbds + ldh +- invsub = iuptri + ldh*ncv +- ipntr(9) = iheigr +- ipntr(10) = iheigi +- ipntr(11) = ihbds +- ipntr(12) = iuptri +- ipntr(13) = invsub +- wrr = 1 +- wri = ncv + 1 +- iwev = wri + ncv +-c +-c %-----------------------------------------% +-c | irr points to the REAL part of the Ritz | +-c | values computed by _neigh before | +-c | exiting _naup2. | +-c | iri points to the IMAGINARY part of the | +-c | Ritz values computed by _neigh | +-c | before exiting _naup2. | +-c | ibd points to the Ritz estimates | +-c | computed by _neigh before exiting | +-c | _naup2. | +-c %-----------------------------------------% +-c +- irr = ipntr(14)+ncv*ncv +- iri = irr+ncv +- ibd = iri+ncv +-c +-c %------------------------------------% +-c | RNORM is B-norm of the RESID(1:N). | +-c %------------------------------------% +-c +- rnorm = workl(ih+2) +- workl(ih+2) = zero +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, ncv, workl(irr), ndigit, +- & '_neupd: Real part of Ritz values passed in from _NAUPD.') +- call dvout (logfil, ncv, workl(iri), ndigit, +- & '_neupd: Imag part of Ritz values passed in from _NAUPD.') +- call dvout (logfil, ncv, workl(ibd), ndigit, +- & '_neupd: Ritz estimates passed in from _NAUPD.') +- end if +-c +- if (rvec) then +-c +- reord = .false. +-c +-c %---------------------------------------------------% +-c | Use the temporary bounds array to store indices | +-c | These will be used to mark the select array later | +-c %---------------------------------------------------% +-c +- do 10 j = 1,ncv +- workl(bounds+j-1) = j +- select(j) = .false. +- 10 continue +-c +-c %-------------------------------------% +-c | Select the wanted Ritz values. | +-c | Sort the Ritz values so that the | +-c | wanted ones appear at the tailing | +-c | NEV positions of workl(irr) and | +-c | workl(iri). Move the corresponding | +-c | error estimates in workl(bound) | +-c | accordingly. | +-c %-------------------------------------% +-c +- np = ncv - nev +- ishift = 0 +- call dngets (ishift , which , nev , +- & np , workl(irr), workl(iri), +- & workl(bounds), workl , workl(np+1)) +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, ncv, workl(irr), ndigit, +- & '_neupd: Real part of Ritz values after calling _NGETS.') +- call dvout (logfil, ncv, workl(iri), ndigit, +- & '_neupd: Imag part of Ritz values after calling _NGETS.') +- call dvout (logfil, ncv, workl(bounds), ndigit, +- & '_neupd: Ritz value indices after calling _NGETS.') +- end if +-c +-c %-----------------------------------------------------% +-c | Record indices of the converged wanted Ritz values | +-c | Mark the select array for possible reordering | +-c %-----------------------------------------------------% +-c +- numcnv = 0 +- do 11 j = 1,ncv +- temp1 = max(eps23, +- & dlapy2 ( workl(irr+ncv-j), workl(iri+ncv-j) )) +- jj = workl(bounds + ncv - j) +- if (numcnv .lt. nconv .and. +- & workl(ibd+jj-1) .le. tol*temp1) then +- select(jj) = .true. +- numcnv = numcnv + 1 +- if (jj .gt. nconv) reord = .true. +- endif +- 11 continue +-c +-c %-----------------------------------------------------------% +-c | Check the count (numcnv) of converged Ritz values with | +-c | the number (nconv) reported by dnaupd. If these two | +-c | are different then there has probably been an error | +-c | caused by incorrect passing of the dnaupd data. | +-c %-----------------------------------------------------------% +-c +- if (msglvl .gt. 2) then +- call ivout(logfil, 1, [numcnv], ndigit, +- & '_neupd: Number of specified eigenvalues') +- call ivout(logfil, 1, [nconv], ndigit, +- & '_neupd: Number of "converged" eigenvalues') +- end if +-c +- if (numcnv .ne. nconv) then +- info = -15 +- go to 9000 +- end if +-c +-c %-----------------------------------------------------------% +-c | Call LAPACK routine dlahqr to compute the real Schur form | +-c | of the upper Hessenberg matrix returned by DNAUPD . | +-c | Make a copy of the upper Hessenberg matrix. | +-c | Initialize the Schur vector matrix Q to the identity. | +-c %-----------------------------------------------------------% +-c +- call dcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1) +- call dlaset ('All', ncv, ncv, +- & zero , one, workl(invsub), +- & ldq) +- call dlahqr (.true., .true. , ncv, +- & 1 , ncv , workl(iuptri), +- & ldh , workl(iheigr), workl(iheigi), +- & 1 , ncv , workl(invsub), +- & ldq , ierr) +- call dcopy (ncv , workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 9000 +- end if +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, ncv, workl(iheigr), ndigit, +- & '_neupd: Real part of the eigenvalues of H') +- call dvout (logfil, ncv, workl(iheigi), ndigit, +- & '_neupd: Imaginary part of the Eigenvalues of H') +- call dvout (logfil, ncv, workl(ihbds), ndigit, +- & '_neupd: Last row of the Schur vector matrix') +- if (msglvl .gt. 3) then +- call dmout (logfil , ncv, ncv , +- & workl(iuptri), ldh, ndigit, +- & '_neupd: The upper quasi-triangular matrix ') +- end if +- end if +-c +- if (reord) then +-c +-c %-----------------------------------------------------% +-c | Reorder the computed upper quasi-triangular matrix. | +-c %-----------------------------------------------------% +-c +- call dtrsen ('None' , 'V' , +- & select , ncv , +- & workl(iuptri), ldh , +- & workl(invsub), ldq , +- & workl(iheigr), workl(iheigi), +- & nconv2 , conds , +- & sep , workl(ihbds) , +- & ncv , iwork , +- & 1 , ierr) +-c +- if (nconv2 .lt. nconv) then +- nconv = nconv2 +- end if +- +- if (ierr .eq. 1) then +- info = 1 +- go to 9000 +- end if +-c +- +- if (msglvl .gt. 2) then +- call dvout (logfil, ncv, workl(iheigr), ndigit, +- & '_neupd: Real part of the eigenvalues of H--reordered') +- call dvout (logfil, ncv, workl(iheigi), ndigit, +- & '_neupd: Imag part of the eigenvalues of H--reordered') +- if (msglvl .gt. 3) then +- call dmout (logfil , ncv, ncv , +- & workl(iuptri), ldq, ndigit, +- & '_neupd: Quasi-triangular matrix after re-ordering') +- end if +- end if +-c +- end if +-c +-c %---------------------------------------% +-c | Copy the last row of the Schur vector | +-c | into workl(ihbds). This will be used | +-c | to compute the Ritz estimates of | +-c | converged Ritz values. | +-c %---------------------------------------% +-c +- call dcopy (ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) +-c +-c %----------------------------------------------------% +-c | Place the computed eigenvalues of H into DR and DI | +-c | if a spectral transformation was not used. | +-c %----------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +- call dcopy (nconv, workl(iheigr), 1, dr, 1) +- call dcopy (nconv, workl(iheigi), 1, di, 1) +- end if +-c +-c %----------------------------------------------------------% +-c | Compute the QR factorization of the matrix representing | +-c | the wanted invariant subspace located in the first NCONV | +-c | columns of workl(invsub,ldq). | +-c %----------------------------------------------------------% +-c +- call dgeqr2 (ncv, nconv , workl(invsub), +- & ldq, workev, workev(ncv+1), +- & ierr) +-c +-c %---------------------------------------------------------% +-c | * Postmultiply V by Q using dorm2r . | +-c | * Copy the first NCONV columns of VQ into Z. | +-c | * Postmultiply Z by R. | +-c | The N by NCONV matrix Z is now a matrix representation | +-c | of the approximate invariant subspace associated with | +-c | the Ritz values in workl(iheigr) and workl(iheigi) | +-c | The first NCONV columns of V are now approximate Schur | +-c | vectors associated with the real upper quasi-triangular | +-c | matrix of order NCONV in workl(iuptri) | +-c %---------------------------------------------------------% +-c +- call dorm2r ('Right', 'Notranspose', n , +- & ncv , nconv , workl(invsub), +- & ldq , workev , v , +- & ldv , workd(n+1) , ierr) +- call dlacpy ('All', n, nconv, v, ldv, z, ldz) +-c +- do 20 j=1, nconv +-c +-c %---------------------------------------------------% +-c | Perform both a column and row scaling if the | +-c | diagonal element of workl(invsub,ldq) is negative | +-c | I'm lazy and don't take advantage of the upper | +-c | quasi-triangular form of workl(iuptri,ldq) | +-c | Note that since Q is orthogonal, R is a diagonal | +-c | matrix consisting of plus or minus ones | +-c %---------------------------------------------------% +-c +- if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then +- call dscal (nconv, -one, workl(iuptri+j-1), ldq) +- call dscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1) +- end if +-c +- 20 continue +-c +- if (howmny .eq. 'A') then +-c +-c %--------------------------------------------% +-c | Compute the NCONV wanted eigenvectors of T | +-c | located in workl(iuptri,ldq). | +-c %--------------------------------------------% +-c +- do 30 j=1, ncv +- if (j .le. nconv) then +- select(j) = .true. +- else +- select(j) = .false. +- end if +- 30 continue +-c +- call dtrevc ('Right', 'Select' , select , +- & ncv , workl(iuptri), ldq , +- & vl , 1 , workl(invsub), +- & ldq , ncv , outncv , +- & workev , ierr) +-c +- if (ierr .ne. 0) then +- info = -9 +- go to 9000 +- end if +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | Euclidean norms are all one. LAPACK subroutine | +-c | dtrevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1; | +-c %------------------------------------------------% +-c +- iconj = 0 +- do 40 j=1, nconv +-c +- if ( workl(iheigi+j-1) .eq. zero ) then +-c +-c %----------------------% +-c | real eigenvalue case | +-c %----------------------% +-c +- temp = dnrm2 ( ncv, workl(invsub+(j-1)*ldq), 1 ) +- call dscal ( ncv, one / temp, +- & workl(invsub+(j-1)*ldq), 1 ) +-c +- else +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c | columns, we further normalize by the | +-c | square root of two. | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- temp = dlapy2 (dnrm2 (ncv, +- & workl(invsub+(j-1)*ldq), +- & 1), +- & dnrm2 (ncv, +- & workl(invsub+j*ldq), +- & 1)) +- call dscal (ncv, one/temp, +- & workl(invsub+(j-1)*ldq), 1 ) +- call dscal (ncv, one/temp, +- & workl(invsub+j*ldq), 1 ) +- iconj = 1 +- else +- iconj = 0 +- end if +-c +- end if +-c +- 40 continue +-c +- call dgemv ('T', ncv, nconv, one, workl(invsub), +- & ldq, workl(ihbds), 1, zero, workev, 1) +-c +- iconj = 0 +- do 45 j=1, nconv +- if (workl(iheigi+j-1) .ne. zero) then +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- workev(j) = dlapy2 (workev(j), workev(j+1)) +- workev(j+1) = workev(j) +- iconj = 1 +- else +- iconj = 0 +- end if +- end if +- 45 continue +-c +- if (msglvl .gt. 2) then +- call dcopy (ncv, workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +- call dvout (logfil, ncv, workl(ihbds), ndigit, +- & '_neupd: Last row of the eigenvector matrix for T') +- if (msglvl .gt. 3) then +- call dmout (logfil, ncv, ncv, workl(invsub), ldq, +- & ndigit, '_neupd: The eigenvector matrix for T') +- end if +- end if +-c +-c %---------------------------------------% +-c | Copy Ritz estimates into workl(ihbds) | +-c %---------------------------------------% +-c +- call dcopy (nconv, workev, 1, workl(ihbds), 1) +-c +-c %---------------------------------------------------------% +-c | Compute the QR factorization of the eigenvector matrix | +-c | associated with leading portion of T in the first NCONV | +-c | columns of workl(invsub,ldq). | +-c %---------------------------------------------------------% +-c +- call dgeqr2 (ncv, nconv , workl(invsub), +- & ldq, workev, workev(ncv+1), +- & ierr) +-c +-c %----------------------------------------------% +-c | * Postmultiply Z by Q. | +-c | * Postmultiply Z by R. | +-c | The N by NCONV matrix Z is now contains the | +-c | Ritz vectors associated with the Ritz values | +-c | in workl(iheigr) and workl(iheigi). | +-c %----------------------------------------------% +-c +- call dorm2r ('Right', 'Notranspose', n , +- & ncv , nconv , workl(invsub), +- & ldq , workev , z , +- & ldz , workd(n+1) , ierr) +-c +- call dtrmm ('Right' , 'Upper' , 'No transpose', +- & 'Non-unit', n , nconv , +- & one , workl(invsub), ldq , +- & z , ldz) +-c +- end if +-c +- else +-c +-c %------------------------------------------------------% +-c | An approximate invariant subspace is not needed. | +-c | Place the Ritz values computed DNAUPD into DR and DI | +-c %------------------------------------------------------% +-c +- call dcopy (nconv, workl(ritzr), 1, dr, 1) +- call dcopy (nconv, workl(ritzi), 1, di, 1) +- call dcopy (nconv, workl(ritzr), 1, workl(iheigr), 1) +- call dcopy (nconv, workl(ritzi), 1, workl(iheigi), 1) +- call dcopy (nconv, workl(bounds), 1, workl(ihbds), 1) +- end if +-c +-c %------------------------------------------------% +-c | Transform the Ritz values and possibly vectors | +-c | and corresponding error bounds of OP to those | +-c | of A*x = lambda*B*x. | +-c %------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +-c +- if (rvec) +- & call dscal (ncv, rnorm, workl(ihbds), 1) +-c +- else +-c +-c %---------------------------------------% +-c | A spectral transformation was used. | +-c | * Determine the Ritz estimates of the | +-c | Ritz values in the original system. | +-c %---------------------------------------% +-c +- if (type .eq. 'SHIFTI') then +-c +- if (rvec) +- & call dscal (ncv, rnorm, workl(ihbds), 1) +-c +- do 50 k=1, ncv +- temp = dlapy2 ( workl(iheigr+k-1), +- & workl(iheigi+k-1) ) +- workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) +- & / temp / temp +- 50 continue +-c +- else if (type .eq. 'REALPT') then +-c +- do 60 k=1, ncv +- 60 continue +-c +- else if (type .eq. 'IMAGPT') then +-c +- do 70 k=1, ncv +- 70 continue +-c +- end if +-c +-c %-----------------------------------------------------------% +-c | * Transform the Ritz values back to the original system. | +-c | For TYPE = 'SHIFTI' the transformation is | +-c | lambda = 1/theta + sigma | +-c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | +-c | Rayleigh quotients or a projection. See remark 3 above.| +-c | NOTES: | +-c | *The Ritz vectors are not affected by the transformation. | +-c %-----------------------------------------------------------% +-c +- if (type .eq. 'SHIFTI') then +-c +- do 80 k=1, ncv +- temp = dlapy2 ( workl(iheigr+k-1), +- & workl(iheigi+k-1) ) +- workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp +- & + sigmar +- workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp +- & + sigmai +- 80 continue +-c +- call dcopy (nconv, workl(iheigr), 1, dr, 1) +- call dcopy (nconv, workl(iheigi), 1, di, 1) +-c +- else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then +-c +- call dcopy (nconv, workl(iheigr), 1, dr, 1) +- call dcopy (nconv, workl(iheigi), 1, di, 1) +-c +- end if +-c +- end if +-c +- if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then +- call dvout (logfil, nconv, dr, ndigit, +- & '_neupd: Untransformed real part of the Ritz values.') +- call dvout (logfil, nconv, di, ndigit, +- & '_neupd: Untransformed imag part of the Ritz values.') +- call dvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Ritz estimates of untransformed Ritz values.') +- else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then +- call dvout (logfil, nconv, dr, ndigit, +- & '_neupd: Real parts of converged Ritz values.') +- call dvout (logfil, nconv, di, ndigit, +- & '_neupd: Imag parts of converged Ritz values.') +- call dvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Associated Ritz estimates.') +- end if +-c +-c %-------------------------------------------------% +-c | Eigenvector Purification step. Formally perform | +-c | one of inverse subspace iteration. Only used | +-c | for MODE = 2. | +-c %-------------------------------------------------% +-c +- if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then +-c +-c %------------------------------------------------% +-c | Purify the computed Ritz vectors by adding a | +-c | little bit of the residual vector: | +-c | T | +-c | resid(:)*( e s ) / theta | +-c | NCV | +-c | where H s = s theta. Remember that when theta | +-c | has nonzero imaginary part, the corresponding | +-c | Ritz vector is stored across two columns of Z. | +-c %------------------------------------------------% +-c +- iconj = 0 +- do 110 j=1, nconv +- if ((workl(iheigi+j-1) .eq. zero) .and. +- & (workl(iheigr+j-1) .ne. zero)) then +- workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / +- & workl(iheigr+j-1) +- else if (iconj .eq. 0) then +- temp = dlapy2 ( workl(iheigr+j-1), workl(iheigi+j-1) ) +- if (temp .ne. zero) then +- workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * +- & workl(iheigr+j-1) + +- & workl(invsub+j*ldq+ncv-1) * +- & workl(iheigi+j-1) ) / temp / temp +- workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * +- & workl(iheigr+j-1) - +- & workl(invsub+(j-1)*ldq+ncv-1) * +- & workl(iheigi+j-1) ) / temp / temp +- end if +- iconj = 1 +- else +- iconj = 0 +- end if +- 110 continue +-c +-c %---------------------------------------% +-c | Perform a rank one update to Z and | +-c | purify all the Ritz vectors together. | +-c %---------------------------------------% +-c +- call dger (n, nconv, one, resid, 1, workev, 1, z, ldz) +-c +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of DNEUPD | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dngets.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dngets.f +deleted file mode 100644 +index 47d3ac2ce0..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dngets.f ++++ /dev/null +@@ -1,231 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dngets +-c +-c\Description: +-c Given the eigenvalues of the upper Hessenberg matrix H, +-c computes the NP shifts AMU that are zeros of the polynomial of +-c degree NP which filters out components of the unwanted eigenvectors +-c corresponding to the AMU's based on some given criteria. +-c +-c NOTE: call this even in the case of user specified shifts in order +-c to sort the eigenvalues, and error bounds of H for later use. +-c +-c\Usage: +-c call dngets +-c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) +-c +-c\Arguments +-c ISHIFT Integer. (INPUT) +-c Method for selecting the implicit shifts at each iteration. +-c ISHIFT = 0: user specified shifts +-c ISHIFT = 1: exact shift with respect to the matrix H. +-c +-c WHICH Character*2. (INPUT) +-c Shift selection criteria. +-c 'LM' -> want the KEV eigenvalues of largest magnitude. +-c 'SM' -> want the KEV eigenvalues of smallest magnitude. +-c 'LR' -> want the KEV eigenvalues of largest real part. +-c 'SR' -> want the KEV eigenvalues of smallest real part. +-c 'LI' -> want the KEV eigenvalues of largest imaginary part. +-c 'SI' -> want the KEV eigenvalues of smallest imaginary part. +-c +-c KEV Integer. (INPUT/OUTPUT) +-c INPUT: KEV+NP is the size of the matrix H. +-c OUTPUT: Possibly increases KEV by one to keep complex conjugate +-c pairs together. +-c +-c NP Integer. (INPUT/OUTPUT) +-c Number of implicit shifts to be computed. +-c OUTPUT: Possibly decreases NP by one to keep complex conjugate +-c pairs together. +-c +-c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT) +-c RITZI On INPUT, RITZR and RITZI contain the real and imaginary +-c parts of the eigenvalues of H. +-c On OUTPUT, RITZR and RITZI are sorted so that the unwanted +-c eigenvalues are in the first NP locations and the wanted +-c portion is in the last KEV locations. When exact shifts are +-c selected, the unwanted part corresponds to the shifts to +-c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues +-c are further sorted so that the ones with largest Ritz values +-c are first. +-c +-c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) +-c Error bounds corresponding to the ordering in RITZ. +-c +-c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** +-c +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c dsortc ARPACK sorting routine. +-c dcopy Level 1 BLAS that copies one vector to another . +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c 1. xxxx +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dngets ( ishift, which, kev, np, ritzr, ritzi, bounds, +- & shiftr, shifti ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- integer ishift, kev, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), +- & shiftr(1), shifti(1) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0, zero = 0.0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy, dsortc, arscnd +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mngets +-c +-c %----------------------------------------------------% +-c | LM, SM, LR, SR, LI, SI case. | +-c | Sort the eigenvalues of H into the desired order | +-c | and apply the resulting order to BOUNDS. | +-c | The eigenvalues are sorted so that the wanted part | +-c | are always in the last KEV locations. | +-c | We first do a pre-processing sort in order to keep | +-c | complex conjugate pairs together | +-c %----------------------------------------------------% +-c +- if (which .eq. 'LM') then +- call dsortc ('LR', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'SM') then +- call dsortc ('SR', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'LR') then +- call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'SR') then +- call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'LI') then +- call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'SI') then +- call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) +- end if +-c +- call dsortc (which, .true., kev+np, ritzr, ritzi, bounds) +-c +-c %-------------------------------------------------------% +-c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | +-c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | +-c | Accordingly decrease NP by one. In other words keep | +-c | complex conjugate pairs together. | +-c %-------------------------------------------------------% +-c +- if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero +- & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then +- np = np - 1 +- kev = kev + 1 +- end if +-c +- if ( ishift .eq. 1 ) then +-c +-c %-------------------------------------------------------% +-c | Sort the unwanted Ritz values used as shifts so that | +-c | the ones with largest Ritz estimates are first | +-c | This will tend to minimize the effects of the | +-c | forward instability of the iteration when they shifts | +-c | are applied in subroutine dnapps. | +-c | Be careful and use 'SR' since we want to sort BOUNDS! | +-c %-------------------------------------------------------% +-c +- call dsortc ( 'SR', .true., np, bounds, ritzr, ritzi ) +- end if +-c +- call arscnd (t1) +- tngets = tngets + (t1 - t0) +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [kev], ndigit, '_ngets: KEV is') +- call ivout (logfil, 1, [np], ndigit, '_ngets: NP is') +- call dvout (logfil, kev+np, ritzr, ndigit, +- & '_ngets: Eigenvalues of current H matrix -- real part') +- call dvout (logfil, kev+np, ritzi, ndigit, +- & '_ngets: Eigenvalues of current H matrix -- imag part') +- call dvout (logfil, kev+np, bounds, ndigit, +- & '_ngets: Ritz estimates of the current KEV+NP Ritz values') +- end if +-c +- return +-c +-c %---------------% +-c | End of dngets | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaitr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaitr.f +deleted file mode 100644 +index 3460d990c9..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaitr.f ++++ /dev/null +@@ -1,853 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsaitr +-c +-c\Description: +-c Reverse communication interface for applying NP additional steps to +-c a K step symmetric Arnoldi factorization. +-c +-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +-c +-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +-c +-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +-c +-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +-c +-c where OP and B are as in dsaupd. The B-norm of r_{k+p} is also +-c computed and returned. +-c +-c\Usage: +-c call dsaitr +-c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c This is for the restart phase to force the new +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y, +-c IPNTR(3) is the pointer into WORK for B * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c When the routine is used in the "shift-and-invert" mode, the +-c vector B * Q is already available and does not need to be +-c recomputed in forming OP * Q. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of matrix B that defines the +-c semi-inner product for the operator OP. See dsaupd. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c K Integer. (INPUT) +-c Current order of H and the number of columns of V. +-c +-c NP Integer. (INPUT) +-c Number of additional Arnoldi steps to take. +-c +-c MODE Integer. (INPUT) +-c Signifies which form for "OP". If MODE=2 then +-c a reduction in the number of B matrix vector multiplies +-c is possible since the B-norm of OP*x is equivalent to +-c the inv(B)-norm of A*x. +-c +-c RESID Double precision array of length N. (INPUT/OUTPUT) +-c On INPUT: RESID contains the residual vector r_{k}. +-c On OUTPUT: RESID contains the residual vector r_{k+p}. +-c +-c RNORM Double precision scalar. (INPUT/OUTPUT) +-c On INPUT the B-norm of r_{k}. +-c On OUTPUT the B-norm of the updated residual r_{k+p}. +-c +-c V Double precision N by K+NP array. (INPUT/OUTPUT) +-c On INPUT: V contains the Arnoldi vectors in the first K +-c columns. +-c On OUTPUT: V contains the new NP Arnoldi vectors in the next +-c NP columns. The first K columns are unchanged. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT) +-c H is used to store the generated symmetric tridiagonal matrix +-c with the subdiagonal in the first column starting at H(2,1) +-c and the main diagonal in the second column. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORK for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The calling program should not +-c use WORKD as temporary workspace during the iteration !!!!!! +-c On INPUT, WORKD(1:N) = B*RESID where RESID is associated +-c with the K step Arnoldi factorization. Used to save some +-c computation at the first step. +-c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated +-c with the K+NP step Arnoldi factorization. +-c +-c INFO Integer. (OUTPUT) +-c = 0: Normal exit. +-c > 0: Size of an invariant subspace of OP is found that is +-c less than K + NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c dgetv0 ARPACK routine to generate the initial vector. +-c ivout ARPACK utility routine that prints integers. +-c dmout ARPACK utility routine that prints matrices. +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c dlascl LAPACK routine for careful scaling of a matrix. +-c dgemv Level 2 BLAS routine for matrix vector multiplication. +-c daxpy Level 1 BLAS that computes a vector triad. +-c dscal Level 1 BLAS that scales a vector. +-c dcopy Level 1 BLAS that copies one vector to another . +-c ddot Level 1 BLAS that computes the scalar product of two vectors. +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/93: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 +-c +-c\Remarks +-c The algorithm implemented is: +-c +-c restart = .false. +-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +-c r_{k} contains the initial residual vector even for k = 0; +-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +-c computed by the calling program. +-c +-c betaj = rnorm ; p_{k+1} = B*r_{k} ; +-c For j = k+1, ..., k+np Do +-c 1) if ( betaj < tol ) stop or restart depending on j. +-c if ( restart ) generate a new starting vector. +-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +-c p_{j} = p_{j}/betaj +-c 3) r_{j} = OP*v_{j} where OP is defined as in dsaupd +-c For shift-invert mode p_{j} = B*v_{j} is already available. +-c wnorm = || OP*v_{j} || +-c 4) Compute the j-th step residual vector. +-c w_{j} = V_{j}^T * B * OP * v_{j} +-c r_{j} = OP*v_{j} - V_{j} * w_{j} +-c alphaj <- j-th component of w_{j} +-c rnorm = || r_{j} || +-c betaj+1 = rnorm +-c If (rnorm > 0.717*wnorm) accept step and go back to 1) +-c 5) Re-orthogonalization step: +-c s = V_{j}'*B*r_{j} +-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +-c alphaj = alphaj + s_{j}; +-c 6) Iterative refinement step: +-c If (rnorm1 > 0.717*rnorm) then +-c rnorm = rnorm1 +-c accept step and go back to 1) +-c Else +-c rnorm = rnorm1 +-c If this is the first time in step 6), go to 5) +-c Else r_{j} lies in the span of V_{j} numerically. +-c Set r_{j} = 0 and rnorm = 0; go to 1) +-c EndIf +-c End Do +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsaitr +- & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, +- & ipntr, workd, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- integer ido, info, k, ldh, ldv, n, mode, np +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Double precision +- & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical first, orth1, orth2, rstart, step3, step4 +- integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, +- & infol, jj +- Double precision +- & rnorm1, wnorm, safmin, temp1 +- save orth1, orth2, rstart, step3, step4, +- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, +- & rnorm1, safmin, wnorm +-c +-c %-----------------------% +-c | Local Array Arguments | +-c %-----------------------% +-c +- Double precision +- & xtemp(2) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external daxpy, dcopy, dscal, dgemv, dgetv0, dvout, dmout, +- & dlascl, ivout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & ddot, dnrm2, dlamch +- external ddot, dnrm2, dlamch +-c +-c %-----------------% +-c | Data statements | +-c %-----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +- first = .false. +-c +-c %--------------------------------% +-c | safmin = safe minimum is such | +-c | that 1/sfmin does not overflow | +-c %--------------------------------% +-c +- safmin = dlamch('safmin') +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msaitr +-c +-c %------------------------------% +-c | Initial call to this routine | +-c %------------------------------% +-c +- info = 0 +- step3 = .false. +- step4 = .false. +- rstart = .false. +- orth1 = .false. +- orth2 = .false. +-c +-c %--------------------------------% +-c | Pointer to the current step of | +-c | the factorization to build | +-c %--------------------------------% +-c +- j = k + 1 +-c +-c %------------------------------------------% +-c | Pointers used for reverse communication | +-c | when using WORKD. | +-c %------------------------------------------% +-c +- ipj = 1 +- irj = ipj + n +- ivj = irj + n +- end if +-c +-c %-------------------------------------------------% +-c | When in reverse communication mode one of: | +-c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +-c | will be .true. | +-c | STEP3: return from computing OP*v_{j}. | +-c | STEP4: return from computing B-norm of OP*v_{j} | +-c | ORTH1: return from computing B-norm of r_{j+1} | +-c | ORTH2: return from computing B-norm of | +-c | correction to the residual vector. | +-c | RSTART: return from OP computations needed by | +-c | dgetv0. | +-c %-------------------------------------------------% +-c +- if (step3) go to 50 +- if (step4) go to 60 +- if (orth1) go to 70 +- if (orth2) go to 90 +- if (rstart) go to 30 +-c +-c %------------------------------% +-c | Else this is the first step. | +-c %------------------------------% +-c +-c %--------------------------------------------------------------% +-c | | +-c | A R N O L D I I T E R A T I O N L O O P | +-c | | +-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [j], ndigit, +- & '_saitr: generating Arnoldi vector no.') +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_saitr: B-norm of the current residual =') +- end if +-c +-c %---------------------------------------------------------% +-c | Check for exact zero. Equivalent to determining whether | +-c | a j-step Arnoldi factorization is present. | +-c %---------------------------------------------------------% +-c +- if (rnorm .gt. zero) go to 40 +-c +-c %---------------------------------------------------% +-c | Invariant subspace found, generate a new starting | +-c | vector which is orthogonal to the current Arnoldi | +-c | basis and continue the iteration. | +-c %---------------------------------------------------% +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_saitr: ****** restart at step ******') +- end if +-c +-c %---------------------------------------------% +-c | ITRY is the loop variable that controls the | +-c | maximum amount of times that a restart is | +-c | attempted. NRSTRT is used by stat.h | +-c %---------------------------------------------% +-c +- nrstrt = nrstrt + 1 +- itry = 1 +- 20 continue +- rstart = .true. +- ido = 0 +- 30 continue +-c +-c %--------------------------------------% +-c | If in reverse communication mode and | +-c | RSTART = .true. flow returns here. | +-c %--------------------------------------% +-c +- call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, +- & resid, rnorm, ipntr, workd, ierr) +- if (ido .ne. 99) go to 9000 +- if (ierr .lt. 0) then +- itry = itry + 1 +- if (itry .le. 3) go to 20 +-c +-c %------------------------------------------------% +-c | Give up after several restart attempts. | +-c | Set INFO to the size of the invariant subspace | +-c | which spans OP and exit. | +-c %------------------------------------------------% +-c +- info = j - 1 +- call arscnd (t1) +- tsaitr = tsaitr + (t1 - t0) +- ido = 99 +- go to 9000 +- end if +-c +- 40 continue +-c +-c %---------------------------------------------------------% +-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +-c | when reciprocating a small RNORM, test against lower | +-c | machine bound. | +-c %---------------------------------------------------------% +-c +- call dcopy (n, resid, 1, v(1,j), 1) +- if (rnorm .ge. safmin) then +- temp1 = one / rnorm +- call dscal (n, temp1, v(1,j), 1) +- call dscal (n, temp1, workd(ipj), 1) +- else +-c +-c %-----------------------------------------% +-c | To scale both v_{j} and p_{j} carefully | +-c | use LAPACK routine SLASCL | +-c %-----------------------------------------% +-c +- call dlascl ('General', i, i, rnorm, one, n, 1, +- & v(1,j), n, infol) +- call dlascl ('General', i, i, rnorm, one, n, 1, +- & workd(ipj), n, infol) +- end if +-c +-c %------------------------------------------------------% +-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +-c | Note that this is not quite yet r_{j}. See STEP 4 | +-c %------------------------------------------------------% +-c +- step3 = .true. +- nopx = nopx + 1 +- call arscnd (t2) +- call dcopy (n, v(1,j), 1, workd(ivj), 1) +- ipntr(1) = ivj +- ipntr(2) = irj +- ipntr(3) = ipj +- ido = 1 +-c +-c %-----------------------------------% +-c | Exit in order to compute OP*v_{j} | +-c %-----------------------------------% +-c +- go to 9000 +- 50 continue +-c +-c %-----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | +-c %-----------------------------------% +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +-c +- step3 = .false. +-c +-c %------------------------------------------% +-c | Put another copy of OP*v_{j} into RESID. | +-c %------------------------------------------% +-c +- call dcopy (n, workd(irj), 1, resid, 1) +-c +-c %-------------------------------------------% +-c | STEP 4: Finish extending the symmetric | +-c | Arnoldi to length j. If MODE = 2 | +-c | then B*OP = B*inv(B)*A = A and | +-c | we don't need to compute B*OP. | +-c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | +-c | assumed to have A*v_{j}. | +-c %-------------------------------------------% +-c +- if (mode .eq. 2) go to 65 +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- step4 = .true. +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-------------------------------------% +-c | Exit in order to compute B*OP*v_{j} | +-c %-------------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy(n, resid, 1 , workd(ipj), 1) +- end if +- 60 continue +-c +-c %-----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | +-c %-----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- step4 = .false. +-c +-c %-------------------------------------% +-c | The following is needed for STEP 5. | +-c | Compute the B-norm of OP*v_{j}. | +-c %-------------------------------------% +-c +- 65 continue +- if (mode .eq. 2) then +-c +-c %----------------------------------% +-c | Note that the B-norm of OP*v_{j} | +-c | is the inv(B)-norm of A*v_{j}. | +-c %----------------------------------% +-c +- wnorm = ddot (n, resid, 1, workd(ivj), 1) +- wnorm = sqrt(abs(wnorm)) +- else if (bmat .eq. 'G') then +- wnorm = ddot (n, resid, 1, workd(ipj), 1) +- wnorm = sqrt(abs(wnorm)) +- else if (bmat .eq. 'I') then +- wnorm = dnrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------% +-c | Compute the j-th residual corresponding | +-c | to the j step factorization. | +-c | Use Classical Gram Schmidt and compute: | +-c | w_{j} <- V_{j}^T * B * OP * v_{j} | +-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +-c %-----------------------------------------% +-c +-c +-c %------------------------------------------% +-c | Compute the j Fourier coefficients w_{j} | +-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +-c %------------------------------------------% +-c +- if (mode .ne. 2 ) then +- call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, +- & workd(irj), 1) +- else if (mode .eq. 2) then +- call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, +- & workd(irj), 1) +- end if +-c +-c %--------------------------------------% +-c | Orthgonalize r_{j} against V_{j}. | +-c | RESID contains OP*v_{j}. See STEP 3. | +-c %--------------------------------------% +-c +- call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, +- & resid, 1) +-c +-c %--------------------------------------% +-c | Extend H to have j rows and columns. | +-c %--------------------------------------% +-c +- h(j,2) = workd(irj + j - 1) +- if (j .eq. 1 .or. rstart) then +- h(j,1) = zero +- else +- h(j,1) = rnorm +- end if +- call arscnd (t4) +-c +- orth1 = .true. +- iter = 0 +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*r_{j} | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd(ipj), 1) +- end if +- 70 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH1 = .true. | +-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- orth1 = .false. +-c +-c %------------------------------% +-c | Compute the B-norm of r_{j}. | +-c %------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm = ddot (n, resid, 1, workd(ipj), 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = dnrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------------------------% +-c | STEP 5: Re-orthogonalization / Iterative refinement phase | +-c | Maximum NITER_ITREF tries. | +-c | | +-c | s = V_{j}^T * B * r_{j} | +-c | r_{j} = r_{j} - V_{j}*s | +-c | alphaj = alphaj + s_{j} | +-c | | +-c | The stopping criteria used for iterative refinement is | +-c | discussed in Parlett's book SEP, page 107 and in Gragg & | +-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +-c | Determine if we need to correct the residual. The goal is | +-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +-c %-----------------------------------------------------------% +-c +- if (rnorm .gt. 0.717*wnorm) go to 100 +- nrorth = nrorth + 1 +-c +-c %---------------------------------------------------% +-c | Enter the Iterative refinement phase. If further | +-c | refinement is necessary, loop back here. The loop | +-c | variable is ITER. Perform a step of Classical | +-c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +-c %---------------------------------------------------% +-c +- 80 continue +-c +- if (msglvl .gt. 2) then +- xtemp(1) = wnorm +- xtemp(2) = rnorm +- call dvout (logfil, 2, xtemp, ndigit, +- & '_saitr: re-orthonalization ; wnorm and rnorm are') +- end if +-c +-c %----------------------------------------------------% +-c | Compute V_{j}^T * B * r_{j}. | +-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +-c %----------------------------------------------------% +-c +- call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, +- & zero, workd(irj), 1) +-c +-c %----------------------------------------------% +-c | Compute the correction to the residual: | +-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +-c | The correction to H is v(:,1:J)*H(1:J,1:J) + | +-c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | +-c | H(j,j) is updated. | +-c %----------------------------------------------% +-c +- call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, +- & one, resid, 1) +-c +- if (j .eq. 1 .or. rstart) h(j,1) = zero +- h(j,2) = h(j,2) + workd(irj + j - 1) +-c +- orth2 = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-----------------------------------% +-c | Exit in order to compute B*r_{j}. | +-c | r_{j} is the corrected residual. | +-c %-----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd(ipj), 1) +- end if +- 90 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH2 = .true. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +-c %-----------------------------------------------------% +-c | Compute the B-norm of the corrected residual r_{j}. | +-c %-----------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm1 = ddot (n, resid, 1, workd(ipj), 1) +- rnorm1 = sqrt(abs(rnorm1)) +- else if (bmat .eq. 'I') then +- rnorm1 = dnrm2(n, resid, 1) +- end if +-c +- if (msglvl .gt. 0 .and. iter .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_saitr: Iterative refinement for Arnoldi residual') +- if (msglvl .gt. 2) then +- xtemp(1) = rnorm +- xtemp(2) = rnorm1 +- call dvout (logfil, 2, xtemp, ndigit, +- & '_saitr: iterative refinement ; rnorm and rnorm1 are') +- end if +- end if +-c +-c %-----------------------------------------% +-c | Determine if we need to perform another | +-c | step of re-orthogonalization. | +-c %-----------------------------------------% +-c +- if (rnorm1 .gt. 0.717*rnorm) then +-c +-c %--------------------------------% +-c | No need for further refinement | +-c %--------------------------------% +-c +- rnorm = rnorm1 +-c +- else +-c +-c %-------------------------------------------% +-c | Another step of iterative refinement step | +-c | is required. NITREF is used by stat.h | +-c %-------------------------------------------% +-c +- nitref = nitref + 1 +- rnorm = rnorm1 +- iter = iter + 1 +- if (iter .le. 1) go to 80 +-c +-c %-------------------------------------------------% +-c | Otherwise RESID is numerically in the span of V | +-c %-------------------------------------------------% +-c +- do 95 jj = 1, n +- resid(jj) = zero +- 95 continue +- rnorm = zero +- end if +-c +-c %----------------------------------------------% +-c | Branch here directly if iterative refinement | +-c | wasn't necessary or after at most NITER_REF | +-c | steps of iterative refinement. | +-c %----------------------------------------------% +-c +- 100 continue +-c +- rstart = .false. +- orth2 = .false. +-c +- call arscnd (t5) +- titref = titref + (t5 - t4) +-c +-c %----------------------------------------------------------% +-c | Make sure the last off-diagonal element is non negative | +-c | If not perform a similarity transformation on H(1:j,1:j) | +-c | and scale v(:,j) by -1. | +-c %----------------------------------------------------------% +-c +- if (h(j,1) .lt. zero) then +- h(j,1) = -h(j,1) +- if ( j .lt. k+np) then +- call dscal(n, -one, v(1,j+1), 1) +- else +- call dscal(n, -one, resid, 1) +- end if +- end if +-c +-c %------------------------------------% +-c | STEP 6: Update j = j+1; Continue | +-c %------------------------------------% +-c +- j = j + 1 +- if (j .gt. k+np) then +- call arscnd (t1) +- tsaitr = tsaitr + (t1 - t0) +- ido = 99 +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, k+np, h(1,2), ndigit, +- & '_saitr: main diagonal of matrix H of step K+NP.') +- if (k+np .gt. 1) then +- call dvout (logfil, k+np-1, h(2,1), ndigit, +- & '_saitr: sub diagonal of matrix H of step K+NP.') +- end if +- end if +-c +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Loop back to extend the factorization by another step. | +-c %--------------------------------------------------------% +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dsaitr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsapps.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsapps.f +deleted file mode 100644 +index f84ef83897..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsapps.f ++++ /dev/null +@@ -1,518 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsapps +-c +-c\Description: +-c Given the Arnoldi factorization +-c +-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +-c +-c apply NP shifts implicitly resulting in +-c +-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +-c +-c where Q is an orthogonal matrix of order KEV+NP. Q is the product of +-c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi +-c factorization becomes: +-c +-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +-c +-c\Usage: +-c call dsapps +-c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Problem size, i.e. dimension of matrix A. +-c +-c KEV Integer. (INPUT) +-c INPUT: KEV+NP is the size of the input matrix H. +-c OUTPUT: KEV is the size of the updated matrix HNEW. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be applied. +-c +-c SHIFT Double precision array of length NP. (INPUT) +-c The shifts to be applied. +-c +-c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) +-c INPUT: V contains the current KEV+NP Arnoldi vectors. +-c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors +-c are in the first KEV columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT) +-c INPUT: H contains the symmetric tridiagonal matrix of the +-c Arnoldi factorization with the subdiagonal in the 1st column +-c starting at H(2,1) and the main diagonal in the 2nd column. +-c OUTPUT: H contains the updated tridiagonal matrix in the +-c KEV leading submatrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RESID Double precision array of length (N). (INPUT/OUTPUT) +-c INPUT: RESID contains the the residual vector r_{k+p}. +-c OUTPUT: RESID is the updated residual vector rnew_{k}. +-c +-c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) +-c Work array used to accumulate the rotations during the bulge +-c chase sweep. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKD Double precision work array of length 2*N. (WORKSPACE) +-c Distributed array used in the application of the accumulated +-c orthogonal matrix Q. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c dlartg LAPACK Givens rotation construction routine. +-c dlacpy LAPACK matrix copy routine. +-c dlaset LAPACK matrix initialization routine. +-c dgemv Level 2 BLAS routine for matrix vector multiplication. +-c daxpy Level 1 BLAS that computes a vector triad. +-c dcopy Level 1 BLAS that copies one vector to another. +-c dscal Level 1 BLAS that scales a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/16/93: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 +-c +-c\Remarks +-c 1. In this version, each shift is applied to all the subblocks of +-c the tridiagonal matrix H and not just to the submatrix that it +-c comes from. This routine assumes that the subdiagonal elements +-c of H that are stored in h(1:kev+np,1) are nonegative upon input +-c and enforce this condition upon output. This version incorporates +-c deflation. See code for documentation. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsapps +- & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer kev, ldh, ldq, ldv, n, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), +- & v(ldv,kev+np), workd(2*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, iend, istart, itop, j, jj, kplusp, msglvl +- logical first +- Double precision +- & a1, a2, a3, a4, big, c, epsmch, f, g, r, s +- save epsmch, first +-c +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset, dvout, +- & ivout, arscnd, dgemv +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlamch +- external dlamch +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs +-c +-c %----------------% +-c | Data statements | +-c %----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +- epsmch = dlamch('Epsilon-Machine') +- first = .false. +- end if +- itop = 1 +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msapps +-c +- kplusp = kev + np +-c +-c %----------------------------------------------% +-c | Initialize Q to the identity matrix of order | +-c | kplusp used to accumulate the rotations. | +-c %----------------------------------------------% +-c +- call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) +-c +-c %----------------------------------------------% +-c | Quick return if there are no shifts to apply | +-c %----------------------------------------------% +-c +- if (np .eq. 0) go to 9000 +-c +-c %----------------------------------------------------------% +-c | Apply the np shifts implicitly. Apply each shift to the | +-c | whole matrix and not just to the submatrix from which it | +-c | comes. | +-c %----------------------------------------------------------% +-c +- do 90 jj = 1, np +-c +- istart = itop +-c +-c %----------------------------------------------------------% +-c | Check for splitting and deflation. Currently we consider | +-c | an off-diagonal element h(i+1,1) negligible if | +-c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | +-c | for i=1:KEV+NP-1. | +-c | If above condition tests true then we set h(i+1,1) = 0. | +-c | Note that h(1:KEV+NP,1) are assumed to be non negative. | +-c %----------------------------------------------------------% +-c +- 20 continue +-c +-c %------------------------------------------------% +-c | The following loop exits early if we encounter | +-c | a negligible off diagonal element. | +-c %------------------------------------------------% +-c +- do 30 i = istart, kplusp-1 +- big = abs(h(i,2)) + abs(h(i+1,2)) +- if (h(i+1,1) .le. epsmch*big) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_sapps: deflation at row/column no.') +- call ivout (logfil, 1, [jj], ndigit, +- & '_sapps: occurred before shift number.') +- call dvout (logfil, 1, h(i+1,1), ndigit, +- & '_sapps: the corresponding off diagonal element') +- end if +- h(i+1,1) = zero +- iend = i +- go to 40 +- end if +- 30 continue +- iend = kplusp +- 40 continue +-c +- if (istart .lt. iend) then +-c +-c %--------------------------------------------------------% +-c | Construct the plane rotation G'(istart,istart+1,theta) | +-c | that attempts to drive h(istart+1,1) to zero. | +-c %--------------------------------------------------------% +-c +- f = h(istart,2) - shift(jj) +- g = h(istart+1,1) +- call dlartg (f, g, c, s, r) +-c +-c %-------------------------------------------------------% +-c | Apply rotation to the left and right of H; | +-c | H <- G' * H * G, where G = G(istart,istart+1,theta). | +-c | This will create a "bulge". | +-c %-------------------------------------------------------% +-c +- a1 = c*h(istart,2) + s*h(istart+1,1) +- a2 = c*h(istart+1,1) + s*h(istart+1,2) +- a4 = c*h(istart+1,2) - s*h(istart+1,1) +- a3 = c*h(istart+1,1) - s*h(istart,2) +- h(istart,2) = c*a1 + s*a2 +- h(istart+1,2) = c*a4 - s*a3 +- h(istart+1,1) = c*a3 + s*a4 +-c +-c %----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G | +-c %----------------------------------------------------% +-c +- do 60 j = 1, min(istart+jj,kplusp) +- a1 = c*q(j,istart) + s*q(j,istart+1) +- q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) +- q(j,istart) = a1 +- 60 continue +-c +-c +-c %----------------------------------------------% +-c | The following loop chases the bulge created. | +-c | Note that the previous rotation may also be | +-c | done within the following loop. But it is | +-c | kept separate to make the distinction among | +-c | the bulge chasing sweeps and the first plane | +-c | rotation designed to drive h(istart+1,1) to | +-c | zero. | +-c %----------------------------------------------% +-c +- do 70 i = istart+1, iend-1 +-c +-c %----------------------------------------------% +-c | Construct the plane rotation G'(i,i+1,theta) | +-c | that zeros the i-th bulge that was created | +-c | by G(i-1,i,theta). g represents the bulge. | +-c %----------------------------------------------% +-c +- f = h(i,1) +- g = s*h(i+1,1) +-c +-c %----------------------------------% +-c | Final update with G(i-1,i,theta) | +-c %----------------------------------% +-c +- h(i+1,1) = c*h(i+1,1) +- call dlartg (f, g, c, s, r) +-c +-c %-------------------------------------------% +-c | The following ensures that h(1:iend-1,1), | +-c | the first iend-2 off diagonal of elements | +-c | H, remain non negative. | +-c %-------------------------------------------% +-c +- if (r .lt. zero) then +- r = -r +- c = -c +- s = -s +- end if +-c +-c %--------------------------------------------% +-c | Apply rotation to the left and right of H; | +-c | H <- G * H * G', where G = G(i,i+1,theta) | +-c %--------------------------------------------% +-c +- h(i,1) = r +-c +- a1 = c*h(i,2) + s*h(i+1,1) +- a2 = c*h(i+1,1) + s*h(i+1,2) +- a3 = c*h(i+1,1) - s*h(i,2) +- a4 = c*h(i+1,2) - s*h(i+1,1) +-c +- h(i,2) = c*a1 + s*a2 +- h(i+1,2) = c*a4 - s*a3 +- h(i+1,1) = c*a3 + s*a4 +-c +-c %----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G | +-c %----------------------------------------------------% +-c +- do 50 j = 1, min( i+jj, kplusp ) +- a1 = c*q(j,i) + s*q(j,i+1) +- q(j,i+1) = - s*q(j,i) + c*q(j,i+1) +- q(j,i) = a1 +- 50 continue +-c +- 70 continue +-c +- end if +-c +-c %--------------------------% +-c | Update the block pointer | +-c %--------------------------% +-c +- istart = iend + 1 +-c +-c %------------------------------------------% +-c | Make sure that h(iend,1) is non-negative | +-c | If not then set h(iend,1) <-- -h(iend,1) | +-c | and negate the last column of Q. | +-c | We have effectively carried out a | +-c | similarity on transformation H | +-c %------------------------------------------% +-c +- if (h(iend,1) .lt. zero) then +- h(iend,1) = -h(iend,1) +- call dscal(kplusp, -one, q(1,iend), 1) +- end if +-c +-c %--------------------------------------------------------% +-c | Apply the same shift to the next block if there is any | +-c %--------------------------------------------------------% +-c +- if (iend .lt. kplusp) go to 20 +-c +-c %-----------------------------------------------------% +-c | Check if we can increase the the start of the block | +-c %-----------------------------------------------------% +-c +- do 80 i = itop, kplusp-1 +- if (h(i+1,1) .gt. zero) go to 90 +- itop = itop + 1 +- 80 continue +-c +-c %-----------------------------------% +-c | Finished applying the jj-th shift | +-c %-----------------------------------% +-c +- 90 continue +-c +-c %------------------------------------------% +-c | All shifts have been applied. Check for | +-c | more possible deflation that might occur | +-c | after the last shift is applied. | +-c %------------------------------------------% +-c +- do 100 i = itop, kplusp-1 +- big = abs(h(i,2)) + abs(h(i+1,2)) +- if (h(i+1,1) .le. epsmch*big) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_sapps: deflation at row/column no.') +- call dvout (logfil, 1, h(i+1,1), ndigit, +- & '_sapps: the corresponding off diagonal element') +- end if +- h(i+1,1) = zero +- end if +- 100 continue +-c +-c %-------------------------------------------------% +-c | Compute the (kev+1)-st column of (V*Q) and | +-c | temporarily store the result in WORKD(N+1:2*N). | +-c | This is not necessary if h(kev+1,1) = 0. | +-c %-------------------------------------------------% +-c +- if ( h(kev+1,1) .gt. zero ) +- & call dgemv ('N', n, kplusp, one, v, ldv, +- & q(1,kev+1), 1, zero, workd(n+1), 1) +-c +-c %-------------------------------------------------------% +-c | Compute column 1 to kev of (V*Q) in backward order | +-c | taking advantage that Q is an upper triangular matrix | +-c | with lower bandwidth np. | +-c | Place results in v(:,kplusp-kev:kplusp) temporarily. | +-c %-------------------------------------------------------% +-c +- do 130 i = 1, kev +- call dgemv ('N', n, kplusp-i+1, one, v, ldv, +- & q(1,kev-i+1), 1, zero, workd, 1) +- call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) +- 130 continue +-c +-c %-------------------------------------------------% +-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +-c %-------------------------------------------------% +-c +- do 140 i = 1, kev +- call dcopy (n, v(1,np+i), 1, v(1,i), 1) +- 140 continue +-c +-c %--------------------------------------------% +-c | Copy the (kev+1)-st column of (V*Q) in the | +-c | appropriate place if h(kev+1,1) .ne. zero. | +-c %--------------------------------------------% +-c +- if ( h(kev+1,1) .gt. zero ) +- & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) +-c +-c %-------------------------------------% +-c | Update the residual vector: | +-c | r <- sigmak*r + betak*v(:,kev+1) | +-c | where | +-c | sigmak = (e_{kev+p}'*Q)*e_{kev} | +-c | betak = e_{kev+1}'*H*e_{kev} | +-c %-------------------------------------% +-c +- call dscal (n, q(kplusp,kev), resid, 1) +- if (h(kev+1,1) .gt. zero) +- & call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, 1, q(kplusp,kev), ndigit, +- & '_sapps: sigmak of the updated residual vector') +- call dvout (logfil, 1, h(kev+1,1), ndigit, +- & '_sapps: betak of the updated residual vector') +- call dvout (logfil, kev, h(1,2), ndigit, +- & '_sapps: updated main diagonal of H for next iteration') +- if (kev .gt. 1) then +- call dvout (logfil, kev-1, h(2,1), ndigit, +- & '_sapps: updated sub diagonal of H for next iteration') +- end if +- end if +-c +- call arscnd (t1) +- tsapps = tsapps + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dsapps | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaup2.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaup2.f +deleted file mode 100644 +index fd4143f537..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaup2.f ++++ /dev/null +@@ -1,851 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsaup2 +-c +-c\Description: +-c Intermediate level interface called by dsaupd. +-c +-c\Usage: +-c call dsaup2 +-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +-c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c +-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dsaupd. +-c MODE, ISHIFT, MXITER: see the definition of IPARAM in dsaupd. +-c +-c NP Integer. (INPUT/OUTPUT) +-c Contains the number of implicit shifts to apply during +-c each Arnoldi/Lanczos iteration. +-c If ISHIFT=1, NP is adjusted dynamically at each iteration +-c to accelerate convergence and prevent stagnation. +-c This is also roughly equal to the number of matrix-vector +-c products (involving the operator OP) per Arnoldi iteration. +-c The logic for adjusting is contained within the current +-c subroutine. +-c If ISHIFT=0, NP is the number of shifts the user needs +-c to provide via reverse communication. 0 < NP < NCV-NEV. +-c NP may be less than NCV-NEV since a leading block of the current +-c upper Tridiagonal matrix has split off and contains "unwanted" +-c Ritz values. +-c Upon termination of the IRA iteration, NP contains the number +-c of "converged" wanted Ritz values. +-c +-c IUPD Integer. (INPUT) +-c IUPD .EQ. 0: use explicit restart instead implicit update. +-c IUPD .NE. 0: use implicit update. +-c +-c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) +-c The Lanczos basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Double precision (NEV+NP) by 2 array. (OUTPUT) +-c H is used to store the generated symmetric tridiagonal matrix +-c The subdiagonal is stored in the first column of H starting +-c at H(2,1). The main diagonal is stored in the arscnd column +-c of H starting at H(1,2). If dsaup2 converges store the +-c B-norm of the final residual vector in H(1,1). +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZ Double precision array of length NEV+NP. (OUTPUT) +-c RITZ(1:NEV) contains the computed Ritz values of OP. +-c +-c BOUNDS Double precision array of length NEV+NP. (OUTPUT) +-c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. +-c +-c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) +-c Private (replicated) work array used to accumulate the +-c rotation in the shift application step. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. It is used in the computation of the +-c tridiagonal eigenvalue problem, the calculation and +-c application of the shifts and convergence checking. +-c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations +-c of WORKL are used in reverse communication to hold the user +-c supplied shifts. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD for +-c vectors used by the Lanczos iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in one of +-c the spectral transformation modes. X is the current +-c operand. +-c ------------------------------------------------------------- +-c +-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Lanczos iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note in dsaupd. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal return. +-c = 1: All possible eigenvalues of OP has been found. +-c NP returns the size of the invariant subspace +-c spanning the operator OP. +-c = 2: No shifts could be applied. +-c = -8: Error return from trid. eigenvalue calculation; +-c This should never happen. +-c = -9: Starting vector is zero. +-c = -9999: Could not build an Lanczos factorization. +-c Size that was built in returned in NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +-c 1980. +-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +-c Computer Physics Communications, 53 (1989), pp 169-179. +-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +-c Implement the Spectral Transformation", Math. Comp., 48 (1987), +-c pp 663-673. +-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +-c SIAM J. Matr. Anal. Apps., January (1993). +-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +-c for Updating the QR decomposition", ACM TOMS, December 1990, +-c Volume 16 Number 4, pp 369-377. +-c +-c\Routines called: +-c dgetv0 ARPACK initial vector generation routine. +-c dsaitr ARPACK Lanczos factorization routine. +-c dsapps ARPACK application of implicit shifts routine. +-c dsconv ARPACK convergence of Ritz values routine. +-c dseigt ARPACK compute Ritz values and error bounds routine. +-c dsgets ARPACK reorder Ritz values and error bounds routine. +-c dsortr ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c dcopy Level 1 BLAS that copies one vector to another. +-c ddot Level 1 BLAS that computes the scalar product of two vectors. +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c dscal Level 1 BLAS that scales a vector. +-c dswap Level 1 BLAS that swaps two vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.4' +-c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) +-c +-c\SCCS Information: @(#) +-c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsaup2 +- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, +- & q, ldq, workl, ipntr, workd, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, +- & n, mode, nev, np +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Double precision +- & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), +- & ritz(nev+np), v(ldv,nev+np), workd(3*n), +- & workl(3*(nev+np)) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character wprime*2 +- logical cnorm, getv0, initv, update, ushift +- integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, +- & np0, nptemp, nevd2, nevm2, kp(3) +- Double precision +- & rnorm, temp, eps23 +- save cnorm, getv0, initv, update, ushift, +- & iter, kplusp, msglvl, nconv, nev0, np0, +- & rnorm, eps23 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy, dgetv0, dsaitr, dscal, dsconv, dseigt, dsgets, +- & dsapps, dsortr, dvout, ivout, arscnd, dswap +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & ddot, dnrm2, dlamch +- external ddot, dnrm2, dlamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic min +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msaup2 +-c +-c %---------------------------------% +-c | Set machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = dlamch('Epsilon-Machine') +- eps23 = eps23**(2.0D+0/3.0D+0) +-c +-c %-------------------------------------% +-c | nev0 and np0 are integer variables | +-c | hold the initial values of NEV & NP | +-c %-------------------------------------% +-c +- nev0 = nev +- np0 = np +-c +-c %-------------------------------------% +-c | kplusp is the bound on the largest | +-c | Lanczos factorization built. | +-c | nconv is the current number of | +-c | "converged" eigenvlues. | +-c | iter is the counter on the current | +-c | iteration step. | +-c %-------------------------------------% +-c +- kplusp = nev0 + np0 +- nconv = 0 +- iter = 0 +-c +-c %--------------------------------------------% +-c | Set flags for computing the first NEV steps | +-c | of the Lanczos factorization. | +-c %--------------------------------------------% +-c +- getv0 = .true. +- update = .false. +- ushift = .false. +- cnorm = .false. +-c +- if (info .ne. 0) then +-c +-c %--------------------------------------------% +-c | User provides the initial residual vector. | +-c %--------------------------------------------% +-c +- initv = .true. +- info = 0 +- else +- initv = .false. +- end if +- end if +-c +-c %---------------------------------------------% +-c | Get a possibly random starting vector and | +-c | force it into the range of the operator OP. | +-c %---------------------------------------------% +-c +- 10 continue +-c +- if (getv0) then +- call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, +- & ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (rnorm .eq. zero) then +-c +-c %-----------------------------------------% +-c | The initial vector is zero. Error exit. | +-c %-----------------------------------------% +-c +- info = -9 +- go to 1200 +- end if +- getv0 = .false. +- ido = 0 +- end if +-c +-c %------------------------------------------------------------% +-c | Back from reverse communication: continue with update step | +-c %------------------------------------------------------------% +-c +- if (update) go to 20 +-c +-c %-------------------------------------------% +-c | Back from computing user specified shifts | +-c %-------------------------------------------% +-c +- if (ushift) go to 50 +-c +-c %-------------------------------------% +-c | Back from computing residual norm | +-c | at the end of the current iteration | +-c %-------------------------------------% +-c +- if (cnorm) go to 100 +-c +-c %----------------------------------------------------------% +-c | Compute the first NEV steps of the Lanczos factorization | +-c %----------------------------------------------------------% +-c +- call dsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, +- & h, ldh, ipntr, workd, info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +-c +-c %-----------------------------------------------------% +-c | dsaitr was unable to build an Lanczos factorization | +-c | of length NEV0. INFO is returned with the size of | +-c | the factorization built. Exit main loop. | +-c %-----------------------------------------------------% +-c +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +-c +-c %--------------------------------------------------------------% +-c | | +-c | M A I N LANCZOS I T E R A T I O N L O O P | +-c | Each iteration implicitly restarts the Lanczos | +-c | factorization in place. | +-c | | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- iter = iter + 1 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [iter], ndigit, +- & '_saup2: **** Start of major iteration number ****') +- end if +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [nev], ndigit, +- & '_saup2: The length of the current Lanczos factorization') +- call ivout (logfil, 1, [np], ndigit, +- & '_saup2: Extend the Lanczos factorization by') +- end if +-c +-c %------------------------------------------------------------% +-c | Compute NP additional steps of the Lanczos factorization. | +-c %------------------------------------------------------------% +-c +- ido = 0 +- 20 continue +- update = .true. +-c +- call dsaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, +- & ldv, h, ldh, ipntr, workd, info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +-c +-c %-----------------------------------------------------% +-c | dsaitr was unable to build an Lanczos factorization | +-c | of length NEV0+NP0. INFO is returned with the size | +-c | of the factorization built. Exit main loop. | +-c %-----------------------------------------------------% +-c +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +- update = .false. +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_saup2: Current B-norm of residual for factorization') +- end if +-c +-c %--------------------------------------------------------% +-c | Compute the eigenvalues and corresponding error bounds | +-c | of the current symmetric tridiagonal matrix. | +-c %--------------------------------------------------------% +-c +- call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 1200 +- end if +-c +-c %----------------------------------------------------% +-c | Make a copy of eigenvalues and corresponding error | +-c | bounds obtained from _seigt. | +-c %----------------------------------------------------% +-c +- call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) +- call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The selection is based on the requested number of | +-c | eigenvalues instead of the current NEV and NP to | +-c | prevent possible misconvergence. | +-c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | +-c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | +-c %---------------------------------------------------% +-c +- nev = nev0 +- np = np0 +- call dsgets (ishift, which, nev, np, ritz, bounds, workl) +-c +-c %-------------------% +-c | Convergence test. | +-c %-------------------% +-c +- call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) +- call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) +-c +- if (msglvl .gt. 2) then +- kp(1) = nev +- kp(2) = np +- kp(3) = nconv +- call ivout (logfil, 3, kp, ndigit, +- & '_saup2: NEV, NP, NCONV are') +- call dvout (logfil, kplusp, ritz, ndigit, +- & '_saup2: The eigenvalues of H') +- call dvout (logfil, kplusp, bounds, ndigit, +- & '_saup2: Ritz estimates of the current NCV Ritz values') +- end if +-c +-c %---------------------------------------------------------% +-c | Count the number of unwanted Ritz values that have zero | +-c | Ritz estimates. If any Ritz estimates are equal to zero | +-c | then a leading block of H of order equal to at least | +-c | the number of Ritz values with zero Ritz estimates has | +-c | split off. None of these Ritz values may be removed by | +-c | shifting. Decrease NP the number of shifts to apply. If | +-c | no shifts may be applied, then prepare to exit | +-c %---------------------------------------------------------% +-c +- nptemp = np +- do 30 j=1, nptemp +- if (bounds(j) .eq. zero) then +- np = np - 1 +- nev = nev + 1 +- end if +- 30 continue +-c +- if ( (nconv .ge. nev0) .or. +- & (iter .gt. mxiter) .or. +- & (np .eq. 0) ) then +-c +-c %------------------------------------------------% +-c | Prepare to exit. Put the converged Ritz values | +-c | and corresponding bounds in RITZ(1:NCONV) and | +-c | BOUNDS(1:NCONV) respectively. Then sort. Be | +-c | careful when NCONV > NP since we don't want to | +-c | swap overlapping locations. | +-c %------------------------------------------------% +-c +- if (which .eq. 'BE') then +-c +-c %-----------------------------------------------------% +-c | Both ends of the spectrum are requested. | +-c | Sort the eigenvalues into algebraically decreasing | +-c | order first then swap low end of the spectrum next | +-c | to high end in appropriate locations. | +-c | NOTE: when np < floor(nev/2) be careful not to swap | +-c | overlapping locations. | +-c %-----------------------------------------------------% +-c +- wprime = 'SA' +- call dsortr (wprime, .true., kplusp, ritz, bounds) +- nevd2 = nev0 / 2 +- nevm2 = nev0 - nevd2 +- if ( nev .gt. 1 ) then +- np = kplusp - nev0 +- call dswap ( min(nevd2,np), ritz(nevm2+1), 1, +- & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) +- call dswap ( min(nevd2,np), bounds(nevm2+1), 1, +- & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) +- end if +-c +- else +-c +-c %--------------------------------------------------% +-c | LM, SM, LA, SA case. | +-c | Sort the eigenvalues of H into the an order that | +-c | is opposite to WHICH, and apply the resulting | +-c | order to BOUNDS. The eigenvalues are sorted so | +-c | that the wanted part are always within the first | +-c | NEV locations. | +-c %--------------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SM' +- if (which .eq. 'SM') wprime = 'LM' +- if (which .eq. 'LA') wprime = 'SA' +- if (which .eq. 'SA') wprime = 'LA' +-c +- call dsortr (wprime, .true., kplusp, ritz, bounds) +-c +- end if +-c +-c %--------------------------------------------------% +-c | Scale the Ritz estimate of each Ritz value | +-c | by 1 / max(eps23,magnitude of the Ritz value). | +-c %--------------------------------------------------% +-c +- do 35 j = 1, nev0 +- temp = max( eps23, abs(ritz(j)) ) +- bounds(j) = bounds(j)/temp +- 35 continue +-c +-c %----------------------------------------------------% +-c | Sort the Ritz values according to the scaled Ritz | +-c | estimates. This will push all the converged ones | +-c | towards the front of ritzr, ritzi, bounds | +-c | (in the case when NCONV < NEV.) | +-c %----------------------------------------------------% +-c +- wprime = 'LA' +- call dsortr(wprime, .true., nev0, bounds, ritz) +-c +-c %----------------------------------------------% +-c | Scale the Ritz estimate back to its original | +-c | value. | +-c %----------------------------------------------% +-c +- do 40 j = 1, nev0 +- temp = max( eps23, abs(ritz(j)) ) +- bounds(j) = bounds(j)*temp +- 40 continue +-c +-c %--------------------------------------------------% +-c | Sort the "converged" Ritz values again so that | +-c | the "threshold" values and their associated Ritz | +-c | estimates appear at the appropriate position in | +-c | ritz and bound. | +-c %--------------------------------------------------% +-c +- if (which .eq. 'BE') then +-c +-c %------------------------------------------------% +-c | Sort the "converged" Ritz values in increasing | +-c | order. The "threshold" values are in the | +-c | middle. | +-c %------------------------------------------------% +-c +- wprime = 'LA' +- call dsortr(wprime, .true., nconv, ritz, bounds) +-c +- else +-c +-c %----------------------------------------------% +-c | In LM, SM, LA, SA case, sort the "converged" | +-c | Ritz values according to WHICH so that the | +-c | "threshold" value appears at the front of | +-c | ritz. | +-c %----------------------------------------------% +- +- call dsortr(which, .true., nconv, ritz, bounds) +-c +- end if +-c +-c %------------------------------------------% +-c | Use h( 1,1 ) as storage to communicate | +-c | rnorm to _seupd if needed | +-c %------------------------------------------% +-c +- h(1,1) = rnorm +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, kplusp, ritz, ndigit, +- & '_saup2: Sorted Ritz values.') +- call dvout (logfil, kplusp, bounds, ndigit, +- & '_saup2: Sorted ritz estimates.') +- end if +-c +-c %------------------------------------% +-c | Max iterations have been exceeded. | +-c %------------------------------------% +-c +- if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 +-c +-c %---------------------% +-c | No shifts to apply. | +-c %---------------------% +-c +- if (np .eq. 0 .and. nconv .lt. nev0) info = 2 +-c +- np = nconv +- go to 1100 +-c +- else if (nconv .lt. nev .and. ishift .eq. 1) then +-c +-c %---------------------------------------------------% +-c | Do not have all the requested eigenvalues yet. | +-c | To prevent possible stagnation, adjust the number | +-c | of Ritz values and the shifts. | +-c %---------------------------------------------------% +-c +- nevbef = nev +- nev = nev + min (nconv, np/2) +- if (nev .eq. 1 .and. kplusp .ge. 6) then +- nev = kplusp / 2 +- else if (nev .eq. 1 .and. kplusp .gt. 2) then +- nev = 2 +- end if +- np = kplusp - nev +-c +-c %---------------------------------------% +-c | If the size of NEV was just increased | +-c | resort the eigenvalues. | +-c %---------------------------------------% +-c +- if (nevbef .lt. nev) +- & call dsgets (ishift, which, nev, np, ritz, bounds, +- & workl) +-c +- end if +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [nconv], ndigit, +- & '_saup2: no. of "converged" Ritz values at this iter.') +- if (msglvl .gt. 1) then +- kp(1) = nev +- kp(2) = np +- call ivout (logfil, 2, kp, ndigit, +- & '_saup2: NEV and NP are') +- call dvout (logfil, nev, ritz(np+1), ndigit, +- & '_saup2: "wanted" Ritz values.') +- call dvout (logfil, nev, bounds(np+1), ndigit, +- & '_saup2: Ritz estimates of the "wanted" values ') +- end if +- end if +- +-c +- if (ishift .eq. 0) then +-c +-c %-----------------------------------------------------% +-c | User specified shifts: reverse communication to | +-c | compute the shifts. They are returned in the first | +-c | NP locations of WORKL. | +-c %-----------------------------------------------------% +-c +- ushift = .true. +- ido = 3 +- go to 9000 +- end if +-c +- 50 continue +-c +-c %------------------------------------% +-c | Back from reverse communication; | +-c | User specified shifts are returned | +-c | in WORKL(1:*NP) | +-c %------------------------------------% +-c +- ushift = .false. +-c +-c +-c %---------------------------------------------------------% +-c | Move the NP shifts to the first NP locations of RITZ to | +-c | free up WORKL. This is for the non-exact shift case; | +-c | in the exact shift case, dsgets already handles this. | +-c %---------------------------------------------------------% +-c +- if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1) +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [np], ndigit, +- & '_saup2: The number of shifts to apply ') +- call dvout (logfil, np, workl, ndigit, +- & '_saup2: shifts selected') +- if (ishift .eq. 1) then +- call dvout (logfil, np, bounds, ndigit, +- & '_saup2: corresponding Ritz estimates') +- end if +- end if +-c +-c %---------------------------------------------------------% +-c | Apply the NP0 implicit shifts by QR bulge chasing. | +-c | Each shift is applied to the entire tridiagonal matrix. | +-c | The first 2*N locations of WORKD are used as workspace. | +-c | After dsapps is done, we have a Lanczos | +-c | factorization of length NEV. | +-c %---------------------------------------------------------% +-c +- call dsapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, +- & workd) +-c +-c %---------------------------------------------% +-c | Compute the B-norm of the updated residual. | +-c | Keep B*RESID in WORKD(1:N) to be used in | +-c | the first step of the next call to dsaitr. | +-c %---------------------------------------------% +-c +- cnorm = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call dcopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*RESID | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call dcopy (n, resid, 1, workd, 1) +- end if +-c +- 100 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(1:N) := B*RESID | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- rnorm = ddot (n, resid, 1, workd, 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = dnrm2(n, resid, 1) +- end if +- cnorm = .false. +- 130 continue +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_saup2: B-norm of residual for NEV factorization') +- call dvout (logfil, nev, h(1,2), ndigit, +- & '_saup2: main diagonal of compressed H matrix') +- call dvout (logfil, nev-1, h(2,1), ndigit, +- & '_saup2: subdiagonal of compressed H matrix') +- end if +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 1100 continue +-c +- mxiter = iter +- nev = nconv +-c +- 1200 continue +- ido = 99 +-c +-c %------------% +-c | Error exit | +-c %------------% +-c +- call arscnd (t1) +- tsaup2 = t1 - t0 +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dsaup2 | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaupd.f +deleted file mode 100644 +index 81a0ce52cc..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsaupd.f ++++ /dev/null +@@ -1,690 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsaupd +-c +-c\Description: +-c +-c Reverse communication interface for the Implicitly Restarted Arnoldi +-c Iteration. For symmetric problems this reduces to a variant of the Lanczos +-c method. This method has been designed to compute approximations to a +-c few eigenpairs of a linear operator OP that is real and symmetric +-c with respect to a real positive semi-definite symmetric matrix B, +-c i.e. +-c +-c B*OP = (OP`)*B. +-c +-c Another way to express this condition is +-c +-c < x,OPy > = < OPx,y > where < z,w > = z`Bw . +-c +-c In the standard eigenproblem B is the identity matrix. +-c ( A` denotes transpose of A) +-c +-c The computed approximate eigenvalues are called Ritz values and +-c the corresponding approximate eigenvectors are called Ritz vectors. +-c +-c dsaupd is usually called iteratively to solve one of the +-c following problems: +-c +-c Mode 1: A*x = lambda*x, A symmetric +-c ===> OP = A and B = I. +-c +-c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite +-c ===> OP = inv[M]*A and B = M. +-c ===> (If M can be factored see remark 3 below) +-c +-c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite +-c ===> OP = (inv[K - sigma*M])*M and B = M. +-c ===> Shift-and-Invert mode +-c +-c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, +-c KG symmetric indefinite +-c ===> OP = (inv[K - sigma*KG])*K and B = K. +-c ===> Buckling mode +-c +-c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite +-c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. +-c ===> Cayley transformed mode +-c +-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +-c should be accomplished either by a direct method +-c using a sparse matrix factorization and solving +-c +-c [A - sigma*M]*w = v or M*w = v, +-c +-c or through an iterative method for solving these +-c systems. If an iterative method is used, the +-c convergence test must be more stringent than +-c the accuracy requirements for the eigenvalue +-c approximations. +-c +-c\Usage: +-c call dsaupd +-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +-c IPNTR, WORKD, WORKL, LWORKL, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to dsaupd . IDO will be set internally to +-c indicate the type of operation to be performed. Control is +-c then given back to the calling routine which has the +-c responsibility to carry out the requested operation and call +-c dsaupd with the result. The operand is given in +-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +-c (If Mode = 2 see remark 5 below) +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c In mode 3,4 and 5, the vector B * X is already +-c available in WORKD(ipntr(3)). It does not +-c need to be recomputed in forming OP * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 3: compute the IPARAM(8) shifts where +-c IPNTR(11) is the pointer into WORKL for +-c placing the shifts. See remark 6 below. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c WHICH Character*2. (INPUT) +-c Specify which of the Ritz values of OP to compute. +-c +-c 'LA' - compute the NEV largest (algebraic) eigenvalues. +-c 'SA' - compute the NEV smallest (algebraic) eigenvalues. +-c 'LM' - compute the NEV largest (in magnitude) eigenvalues. +-c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. +-c 'BE' - compute NEV eigenvalues, half from each end of the +-c spectrum. When NEV is odd, compute one more from the +-c high end than from the low end. +-c (see remark 1 below) +-c +-c NEV Integer. (INPUT) +-c Number of eigenvalues of OP to be computed. 0 < NEV < N. +-c +-c TOL Double precision scalar. (INPUT) +-c Stopping criterion: the relative accuracy of the Ritz value +-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). +-c If TOL .LE. 0. is passed a default is set: +-c DEFAULT = DLAMCH ('EPS') (machine precision as computed +-c by the LAPACK auxiliary subroutine DLAMCH ). +-c +-c RESID Double precision array of length N. (INPUT/OUTPUT) +-c On INPUT: +-c If INFO .EQ. 0, a random initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c On OUTPUT: +-c RESID contains the final residual vector. +-c +-c NCV Integer. (INPUT) +-c Number of columns of the matrix V (less than or equal to N). +-c This will indicate how many Lanczos vectors are generated +-c at each iteration. After the startup phase in which NEV +-c Lanczos vectors are generated, the algorithm generates +-c NCV-NEV Lanczos vectors at each subsequent update iteration. +-c Most of the cost in generating each Lanczos vector is in the +-c matrix-vector product OP*x. (See remark 4 below). +-c +-c V Double precision N by NCV array. (OUTPUT) +-c The NCV columns of V contain the Lanczos basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c IPARAM Integer array of length 11. (INPUT/OUTPUT) +-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +-c The shifts selected at each iteration are used to restart +-c the Arnoldi iteration in an implicit fashion. +-c ------------------------------------------------------------- +-c ISHIFT = 0: the shifts are provided by the user via +-c reverse communication. The NCV eigenvalues of +-c the current tridiagonal matrix T are returned in +-c the part of WORKL array corresponding to RITZ. +-c See remark 6 below. +-c ISHIFT = 1: exact shifts with respect to the reduced +-c tridiagonal matrix T. This is equivalent to +-c restarting the iteration with a starting vector +-c that is a linear combination of Ritz vectors +-c associated with the "wanted" Ritz values. +-c ------------------------------------------------------------- +-c +-c IPARAM(2) = LEVEC +-c No longer referenced. See remark 2 below. +-c +-c IPARAM(3) = MXITER +-c On INPUT: maximum number of Arnoldi update iterations allowed. +-c On OUTPUT: actual number of Arnoldi update iterations taken. +-c +-c IPARAM(4) = NB: blocksize to be used in the recurrence. +-c The code currently works only for NB = 1. +-c +-c IPARAM(5) = NCONV: number of "converged" Ritz values. +-c This represents the number of Ritz values that satisfy +-c the convergence criterion. +-c +-c IPARAM(6) = IUPD +-c No longer referenced. Implicit restarting is ALWAYS used. +-c +-c IPARAM(7) = MODE +-c On INPUT determines what type of eigenproblem is being solved. +-c Must be 1,2,3,4,5; See under \Description of dsaupd for the +-c five modes available. +-c +-c IPARAM(8) = NP +-c When ido = 3 and the user provides shifts through reverse +-c communication (IPARAM(1)=0), dsaupd returns NP, the number +-c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark +-c 6 below. +-c +-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +-c OUTPUT: NUMOP = total number of OP*x operations, +-c NUMOPB = total number of B*x operations if BMAT='G', +-c NUMREO = total number of steps of re-orthogonalization. +-c +-c IPNTR Integer array of length 11. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD and WORKL +-c arrays for matrices/vectors used by the Lanczos iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X in WORKD. +-c IPNTR(2): pointer to the current result vector Y in WORKD. +-c IPNTR(3): pointer to the vector B * X in WORKD when used in +-c the shift-and-invert mode. +-c IPNTR(4): pointer to the next available location in WORKL +-c that is untouched by the program. +-c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. +-c IPNTR(6): pointer to the NCV RITZ values array in WORKL. +-c IPNTR(7): pointer to the Ritz estimates in array WORKL associated +-c with the Ritz values located in RITZ in WORKL. +-c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. +-c +-c Note: IPNTR(8:10) is only referenced by dseupd . See Remark 2. +-c IPNTR(8): pointer to the NCV RITZ values of the original system. +-c IPNTR(9): pointer to the NCV corresponding error bounds. +-c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors +-c of the tridiagonal matrix T. Only referenced by +-c dseupd if RVEC = .TRUE. See Remarks. +-c ------------------------------------------------------------- +-c +-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration. Upon termination +-c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired +-c subroutine dseupd uses this output. +-c See Data Distribution Note below. +-c +-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. See Data Distribution Note below. +-c +-c LWORKL Integer. (INPUT) +-c LWORKL must be at least NCV**2 + 8*NCV . +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal exit. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. IPARAM(5) +-c returns the number of wanted converged Ritz values. +-c = 2: No longer an informational error. Deprecated starting +-c with release 2 of ARPACK. +-c = 3: No shifts could be applied during a cycle of the +-c Implicitly restarted Arnoldi iteration. One possibility +-c is to increase the size of NCV relative to NEV. +-c See remark 4 below. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV must be greater than NEV and less than or equal to N. +-c = -4: The maximum number of Arnoldi update iterations allowed +-c must be greater than zero. +-c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work array WORKL is not sufficient. +-c = -8: Error return from trid. eigenvalue calculation; +-c Informatinal error from LAPACK routine dsteqr . +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3,4,5. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: IPARAM(1) must be equal to 0 or 1. +-c = -13: NEV and WHICH = 'BE' are incompatible. +-c = -9999: Could not build an Arnoldi factorization. +-c IPARAM(5) returns the size of the current Arnoldi +-c factorization. The user is advised to check that +-c enough workspace and array storage has been allocated. +-c +-c +-c\Remarks +-c 1. The converged Ritz values are always returned in ascending +-c algebraic order. The computed Ritz values are approximate +-c eigenvalues of OP. The selection of WHICH should be made +-c with this in mind when Mode = 3,4,5. After convergence, +-c approximate eigenvalues of the original problem may be obtained +-c with the ARPACK subroutine dseupd . +-c +-c 2. If the Ritz vectors corresponding to the converged Ritz values +-c are needed, the user must call dseupd immediately following completion +-c of dsaupd . This is new starting with version 2.1 of ARPACK. +-c +-c 3. If M can be factored into a Cholesky factorization M = LL` +-c then Mode = 2 should not be selected. Instead one should use +-c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +-c linear systems should be solved with L and L` rather +-c than computing inverses. After convergence, an approximate +-c eigenvector z of the original problem is recovered by solving +-c L`z = x where x is a Ritz vector of OP. +-c +-c 4. At present there is no a-priori analysis to guide the selection +-c of NCV relative to NEV. The only formal requirement is that NCV > NEV. +-c However, it is recommended that NCV .ge. 2*NEV. If many problems of +-c the same type are to be solved, one should experiment with increasing +-c NCV while keeping NEV fixed for a given test problem. This will +-c usually decrease the required number of OP*x operations but it +-c also increases the work and storage required to maintain the orthogonal +-c basis vectors. The optimal "cross-over" with respect to CPU time +-c is problem dependent and must be determined empirically. +-c +-c 5. If IPARAM(7) = 2 then in the Reverse communication interface the user +-c must do the following. When IDO = 1, Y = OP * X is to be computed. +-c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user +-c must overwrite X with A*X. Y is then the solution to the linear set +-c of equations B*Y = A*X. +-c +-c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +-c NP = IPARAM(8) shifts in locations: +-c 1 WORKL(IPNTR(11)) +-c 2 WORKL(IPNTR(11)+1) +-c . +-c . +-c . +-c NP WORKL(IPNTR(11)+NP-1). +-c +-c The eigenvalues of the current tridiagonal matrix are located in +-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the +-c order defined by WHICH. The associated Ritz estimates are located in +-c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). +-c +-c----------------------------------------------------------------------- +-c +-c\Data Distribution Note: +-c +-c Fortran-D syntax: +-c ================ +-c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) +-c DECOMPOSE D1(N), D2(N,NCV) +-c ALIGN RESID(I) with D1(I) +-c ALIGN V(I,J) with D2(I,J) +-c ALIGN WORKD(I) with D1(I) range (1:N) +-c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) +-c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) +-c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) +-c REPLICATED WORKL(LWORKL) +-c +-c Cray MPP syntax: +-c =============== +-c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) +-c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) +-c REPLICATED WORKL(LWORKL) +-c +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +-c 1980. +-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +-c Computer Physics Communications, 53 (1989), pp 169-179. +-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +-c Implement the Spectral Transformation", Math. Comp., 48 (1987), +-c pp 663-673. +-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +-c SIAM J. Matr. Anal. Apps., January (1993). +-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +-c for Updating the QR decomposition", ACM TOMS, December 1990, +-c Volume 16 Number 4, pp 369-377. +-c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral +-c Transformations in a k-Step Arnoldi Method". In Preparation. +-c +-c\Routines called: +-c dsaup2 ARPACK routine that implements the Implicitly Restarted +-c Arnoldi Iteration. +-c dstats ARPACK routine that initialize timing and other statistics +-c variables. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\Remarks +-c 1. None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsaupd +- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, +- & ipntr, workd, workl, lworkl, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ldv, lworkl, n, ncv, nev +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(11) +- Double precision +- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0 , zero = 0.0D+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, msglvl, mxiter, mode, nb, +- & nev0, next, np, ritz, j +- save bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, msglvl, mxiter, mode, nb, +- & nev0, next, np, ritz +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dsaup2 , dvout , ivout, arscnd, dstats +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlamch +- external dlamch +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call dstats +- call arscnd (t0) +- msglvl = msaupd +-c +- ierr = 0 +- ishift = iparam(1) +- mxiter = iparam(3) +-c nb = iparam(4) +- nb = 1 +-c +-c %--------------------------------------------% +-c | Revision 2 performs only implicit restart. | +-c %--------------------------------------------% +-c +- iupd = 1 +- mode = iparam(7) +-c +-c %----------------% +-c | Error checking | +-c %----------------% +-c +- if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev .or. ncv .gt. n) then +- ierr = -3 +- end if +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c %----------------------------------------------% +-c +- np = ncv - nev +-c +- if (mxiter .le. 0) ierr = -4 +- if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LA' .and. +- & which .ne. 'SA' .and. +- & which .ne. 'BE') ierr = -5 +- if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 +-c +- if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 +- if (mode .lt. 1 .or. mode .gt. 5) then +- ierr = -10 +- else if (mode .eq. 1 .and. bmat .eq. 'G') then +- ierr = -11 +- else if (ishift .lt. 0 .or. ishift .gt. 1) then +- ierr = -12 +- else if (nev .eq. 1 .and. which .eq. 'BE') then +- ierr = -13 +- end if +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- ido = 99 +- go to 9000 +- end if +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- if (nb .le. 0) nb = 1 +- if (tol .le. zero) tol = dlamch ('EpsMach') +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c | NEV0 is the local variable designating the | +-c | size of the invariant subspace desired. | +-c %----------------------------------------------% +-c +- np = ncv - nev +- nev0 = nev +-c +-c %-----------------------------% +-c | Zero out internal workspace | +-c %-----------------------------% +-c +- do 10 j = 1, ncv**2 + 8*ncv +- workl(j) = zero +- 10 continue +-c +-c %-------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:2*ncv) := generated tridiagonal matrix | +-c | workl(2*ncv+1:2*ncv+ncv) := ritz values | +-c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | +-c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | +-c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | +-c %-------------------------------------------------------% +-c +- ldh = ncv +- ldq = ncv +- ih = 1 +- ritz = ih + 2*ldh +- bounds = ritz + ncv +- iq = bounds + ncv +- iw = iq + ncv**2 +- next = iw + 3*ncv +-c +- ipntr(4) = next +- ipntr(5) = ih +- ipntr(6) = ritz +- ipntr(7) = bounds +- ipntr(11) = iw +- end if +-c +-c %-------------------------------------------------------% +-c | Carry out the Implicitly restarted Lanczos Iteration. | +-c %-------------------------------------------------------% +-c +- call dsaup2 +- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), +- & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, +- & info ) +-c +-c %--------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP or shifts. | +-c %--------------------------------------------------% +-c +- if (ido .eq. 3) iparam(8) = np +- if (ido .ne. 99) go to 9000 +-c +- iparam(3) = mxiter +- iparam(5) = np +- iparam(9) = nopx +- iparam(10) = nbx +- iparam(11) = nrorth +-c +-c %------------------------------------% +-c | Exit if there was an informational | +-c | error within dsaup2 . | +-c %------------------------------------% +-c +- if (info .lt. 0) go to 9000 +- if (info .eq. 2) info = 3 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [mxiter], ndigit, +- & '_saupd: number of update iterations taken') +- call ivout (logfil, 1, [np], ndigit, +- & '_saupd: number of "converged" Ritz values') +- call dvout (logfil, np, workl(Ritz), ndigit, +- & '_saupd: final Ritz values') +- call dvout (logfil, np, workl(Bounds), ndigit, +- & '_saupd: corresponding error bounds') +- end if +-c +- call arscnd (t1) +- tsaupd = t1 - t0 +-c +- if (msglvl .gt. 0) then +-c +-c %--------------------------------------------------------% +-c | Version Number & Version Date are defined in version.h | +-c %--------------------------------------------------------% +-c +- write (6,1000) +- write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, +- & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, +- & tgetv0, tseigt, tsgets, tsapps, tsconv +- 1000 format (//, +- & 5x, '==========================================',/ +- & 5x, '= Symmetric implicit Arnoldi update code =',/ +- & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ +- & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ +- & 5x, '==========================================',/ +- & 5x, '= Summary of timing statistics =',/ +- & 5x, '==========================================',//) +- 1100 format ( +- & 5x, 'Total number update iterations = ', i5,/ +- & 5x, 'Total number of OP*x operations = ', i5,/ +- & 5x, 'Total number of B*x operations = ', i5,/ +- & 5x, 'Total number of reorthogonalization steps = ', i5,/ +- & 5x, 'Total number of iterative refinement steps = ', i5,/ +- & 5x, 'Total number of restart steps = ', i5,/ +- & 5x, 'Total time in user OP*x operation = ', f12.6,/ +- & 5x, 'Total time in user B*x operation = ', f12.6,/ +- & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ +- & 5x, 'Total time in saup2 routine = ', f12.6,/ +- & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ +- & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ +- & 5x, 'Total time in (re)start vector generation = ', f12.6,/ +- & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ +- & 5x, 'Total time in getting the shifts = ', f12.6,/ +- & 5x, 'Total time in applying the shifts = ', f12.6,/ +- & 5x, 'Total time in convergence testing = ', f12.6) +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of dsaupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsconv.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsconv.f +deleted file mode 100644 +index 82dbb6e611..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsconv.f ++++ /dev/null +@@ -1,138 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsconv +-c +-c\Description: +-c Convergence testing for the symmetric Arnoldi eigenvalue routine. +-c +-c\Usage: +-c call dsconv +-c ( N, RITZ, BOUNDS, TOL, NCONV ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Number of Ritz values to check for convergence. +-c +-c RITZ Double precision array of length N. (INPUT) +-c The Ritz values to be checked for convergence. +-c +-c BOUNDS Double precision array of length N. (INPUT) +-c Ritz estimates associated with the Ritz values in RITZ. +-c +-c TOL Double precision scalar. (INPUT) +-c Desired relative accuracy for a Ritz value to be considered +-c "converged". +-c +-c NCONV Integer scalar. (OUTPUT) +-c Number of "converged" Ritz values. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c dlamch LAPACK routine that determines machine constants. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\Remarks +-c 1. Starting with version 2.4, this routine no longer uses the +-c Parlett strategy using the gap conditions. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsconv (n, ritz, bounds, tol, nconv) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer n, nconv +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & ritz(n), bounds(n) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i +- Double precision +- & temp, eps23 +-c +-c %-------------------% +-c | External routines | +-c %-------------------% +-c +- Double precision +- & dlamch +- external dlamch +- +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- call arscnd (t0) +-c +- eps23 = dlamch('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0) +-c +- nconv = 0 +- do 10 i = 1, n +-c +-c %-----------------------------------------------------% +-c | The i-th Ritz value is considered "converged" | +-c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | +-c %-----------------------------------------------------% +-c +- temp = max( eps23, abs(ritz(i)) ) +- if ( bounds(i) .le. tol*temp ) then +- nconv = nconv + 1 +- end if +-c +- 10 continue +-c +- call arscnd (t1) +- tsconv = tsconv + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of dsconv | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseigt.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseigt.f +deleted file mode 100644 +index 5e20c805bf..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseigt.f ++++ /dev/null +@@ -1,181 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dseigt +-c +-c\Description: +-c Compute the eigenvalues of the current symmetric tridiagonal matrix +-c and the corresponding error bounds given the current residual norm. +-c +-c\Usage: +-c call dseigt +-c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) +-c +-c\Arguments +-c RNORM Double precision scalar. (INPUT) +-c RNORM contains the residual norm corresponding to the current +-c symmetric tridiagonal matrix H. +-c +-c N Integer. (INPUT) +-c Size of the symmetric tridiagonal matrix H. +-c +-c H Double precision N by 2 array. (INPUT) +-c H contains the symmetric tridiagonal matrix with the +-c subdiagonal in the first column starting at H(2,1) and the +-c main diagonal in second column. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c EIG Double precision array of length N. (OUTPUT) +-c On output, EIG contains the N eigenvalues of H possibly +-c unsorted. The BOUNDS arrays are returned in the +-c same sorted order as EIG. +-c +-c BOUNDS Double precision array of length N. (OUTPUT) +-c On output, BOUNDS contains the error estimates corresponding +-c to the eigenvalues EIG. This is equal to RNORM times the +-c last components of the eigenvectors corresponding to the +-c eigenvalues in EIG. +-c +-c WORKL Double precision work array of length 3*N. (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c IERR Integer. (OUTPUT) +-c Error exit flag from dstqrb. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c dstqrb ARPACK routine that computes the eigenvalues and the +-c last components of the eigenvectors of a symmetric +-c and tridiagonal matrix. +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine that prints vectors. +-c dcopy Level 1 BLAS that copies one vector to another. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dseigt +- & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer ierr, ldh, n +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & eig(n), bounds(n), h(ldh,2), workl(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & zero +- parameter (zero = 0.0D+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, k, msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy, dstqrb, dvout, arscnd +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mseigt +-c +- if (msglvl .gt. 0) then +- call dvout (logfil, n, h(1,2), ndigit, +- & '_seigt: main diagonal of matrix H') +- if (n .gt. 1) then +- call dvout (logfil, n-1, h(2,1), ndigit, +- & '_seigt: sub diagonal of matrix H') +- end if +- end if +-c +- call dcopy (n, h(1,2), 1, eig, 1) +- call dcopy (n-1, h(2,1), 1, workl, 1) +- call dstqrb (n, eig, workl, bounds, workl(n+1), ierr) +- if (ierr .ne. 0) go to 9000 +- if (msglvl .gt. 1) then +- call dvout (logfil, n, bounds, ndigit, +- & '_seigt: last row of the eigenvector matrix for H') +- end if +-c +-c %-----------------------------------------------% +-c | Finally determine the error bounds associated | +-c | with the n Ritz values of H. | +-c %-----------------------------------------------% +-c +- do 30 k = 1, n +- bounds(k) = rnorm*abs(bounds(k)) +- 30 continue +-c +- call arscnd (t1) +- tseigt = tseigt + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dseigt | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsesrt.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsesrt.f +deleted file mode 100644 +index 833fba4e6c..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsesrt.f ++++ /dev/null +@@ -1,217 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsesrt +-c +-c\Description: +-c Sort the array X in the order specified by WHICH and optionally +-c apply the permutation to the columns of the matrix A. +-c +-c\Usage: +-c call dsesrt +-c ( WHICH, APPLY, N, X, NA, A, LDA) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> X is sorted into increasing order of magnitude. +-c 'SM' -> X is sorted into decreasing order of magnitude. +-c 'LA' -> X is sorted into increasing order of algebraic. +-c 'SA' -> X is sorted into decreasing order of algebraic. +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to A. +-c APPLY = .FALSE. -> do not apply the sorted order to A. +-c +-c N Integer. (INPUT) +-c Dimension of the array X. +-c +-c X Double precision array of length N. (INPUT/OUTPUT) +-c The array to be sorted. +-c +-c NA Integer. (INPUT) +-c Number of rows of the matrix A. +-c +-c A Double precision array of length NA by N. (INPUT/OUTPUT) +-c +-c LDA Integer. (INPUT) +-c Leading dimension of A. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Routines +-c dswap Level 1 BLAS that swaps the contents of two vectors. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.1'. +-c Adapted from the sort routine in LANSO and +-c the ARPACK code dsortr +-c +-c\SCCS Information: @(#) +-c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsesrt (which, apply, n, x, na, a, lda) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer lda, n, na +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & x(0:n-1), a(lda, 0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Double precision +- & temp +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dswap +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'SA') then +-c +-c X is sorted into decreasing order of algebraic. +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- if (x(j).lt.x(j+igap)) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 30 +- endif +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c X is sorted into decreasing order of magnitude. +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j.lt.0) go to 60 +-c +- if (abs(x(j)).lt.abs(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LA') then +-c +-c X is sorted into increasing order of algebraic. +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (x(j).gt.x(j+igap)) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'LM') then +-c +-c X is sorted into increasing order of magnitude. +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (abs(x(j)).gt.abs(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dsesrt | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseupd.f +deleted file mode 100644 +index ae123a207e..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dseupd.f ++++ /dev/null +@@ -1,867 +0,0 @@ +-c\BeginDoc +-c +-c\Name: dseupd +-c +-c\Description: +-c +-c This subroutine returns the converged approximations to eigenvalues +-c of A*z = lambda*B*z and (optionally): +-c +-c (1) the corresponding approximate eigenvectors, +-c +-c (2) an orthonormal (Lanczos) basis for the associated approximate +-c invariant subspace, +-c +-c (3) Both. +-c +-c There is negligible additional cost to obtain eigenvectors. An orthonormal +-c (Lanczos) basis is always computed. There is an additional storage cost +-c of n*nev if both are requested (in this case a separate array Z must be +-c supplied). +-c +-c These quantities are obtained from the Lanczos factorization computed +-c by DSAUPD for the linear operator OP prescribed by the MODE selection +-c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before +-c this routine is called. These approximate eigenvalues and vectors are +-c commonly called Ritz values and Ritz vectors respectively. They are +-c referred to as such in the comments that follow. The computed orthonormal +-c basis for the invariant subspace corresponding to these Ritz values is +-c referred to as a Lanczos basis. +-c +-c See documentation in the header of the subroutine DSAUPD for a definition +-c of OP as well as other terms and the relation of computed Ritz values +-c and vectors of OP with respect to the given problem A*z = lambda*B*z. +-c +-c The approximate eigenvalues of the original problem are returned in +-c ascending algebraic order. The user may elect to call this routine +-c once for each desired Ritz vector and store it peripherally if desired. +-c There is also the option of computing a selected set of these vectors +-c with a single call. +-c +-c\Usage: +-c call dseupd +-c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, +-c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) +-c +-c RVEC LOGICAL (INPUT) +-c Specifies whether Ritz vectors corresponding to the Ritz value +-c approximations to the eigenproblem A*z = lambda*B*z are computed. +-c +-c RVEC = .FALSE. Compute Ritz values only. +-c +-c RVEC = .TRUE. Compute Ritz vectors. +-c +-c HOWMNY Character*1 (INPUT) +-c Specifies how many Ritz vectors are wanted and the form of Z +-c the matrix of Ritz vectors. See remark 1 below. +-c = 'A': compute NEV Ritz vectors; +-c = 'S': compute some of the Ritz vectors, specified +-c by the logical array SELECT. +-c +-c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) +-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +-c computed. To select the Ritz vector corresponding to a +-c Ritz value D(j), SELECT(j) must be set to .TRUE.. +-c If HOWMNY = 'A' , SELECT is used as a workspace for +-c reordering the Ritz values. +-c +-c D Double precision array of dimension NEV. (OUTPUT) +-c On exit, D contains the Ritz value approximations to the +-c eigenvalues of A*z = lambda*B*z. The values are returned +-c in ascending order. If IPARAM(7) = 3,4,5 then D represents +-c the Ritz values of OP computed by dsaupd transformed to +-c those of the original eigensystem A*z = lambda*B*z. If +-c IPARAM(7) = 1,2 then the Ritz values of OP are the same +-c as the those of A*z = lambda*B*z. +-c +-c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT) +-c On exit, Z contains the B-orthonormal Ritz vectors of the +-c eigensystem A*z = lambda*B*z corresponding to the Ritz +-c value approximations. +-c If RVEC = .FALSE. then Z is not referenced. +-c NOTE: The array Z may be set equal to first NEV columns of the +-c Arnoldi/Lanczos basis array V computed by DSAUPD . +-c +-c LDZ Integer. (INPUT) +-c The leading dimension of the array Z. If Ritz vectors are +-c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. +-c +-c SIGMA Double precision (INPUT) +-c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if +-c IPARAM(7) = 1 or 2. +-c +-c +-c **** The remaining arguments MUST be the same as for the **** +-c **** call to DSAUPD that was just completed. **** +-c +-c NOTE: The remaining arguments +-c +-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +-c WORKD, WORKL, LWORKL, INFO +-c +-c must be passed directly to DSEUPD following the last call +-c to DSAUPD . These arguments MUST NOT BE MODIFIED between +-c the the last call to DSAUPD and the call to DSEUPD . +-c +-c Two of these parameters (WORKL, INFO) are also output parameters: +-c +-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +-c WORKL(1:4*ncv) contains information obtained in +-c dsaupd . They are not changed by dseupd . +-c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the +-c untransformed Ritz values, the computed error estimates, +-c and the associated eigenvector matrix of H. +-c +-c Note: IPNTR(8:10) contains the pointer into WORKL for addresses +-c of the above information computed by dseupd . +-c ------------------------------------------------------------- +-c IPNTR(8): pointer to the NCV RITZ values of the original system. +-c IPNTR(9): pointer to the NCV corresponding error bounds. +-c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors +-c of the tridiagonal matrix T. Only referenced by +-c dseupd if RVEC = .TRUE. See Remarks. +-c ------------------------------------------------------------- +-c +-c INFO Integer. (OUTPUT) +-c Error flag on output. +-c = 0: Normal exit. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV must be greater than NEV and less than or equal to N. +-c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work WORKL array is not sufficient. +-c = -8: Error return from trid. eigenvalue calculation; +-c Information error from LAPACK routine dsteqr . +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3,4,5. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: NEV and WHICH = 'BE' are incompatible. +-c = -14: DSAUPD did not find any eigenvalues to sufficient +-c accuracy. +-c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. +-c = -16: HOWMNY = 'S' not yet implemented +-c = -17: DSEUPD got a different count of the number of converged +-c Ritz values than DSAUPD got. This indicates the user +-c probably made an error in passing data from DSAUPD to +-c DSEUPD or that the data was modified before entering +-c DSEUPD . +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +-c 1980. +-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +-c Computer Physics Communications, 53 (1989), pp 169-179. +-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +-c Implement the Spectral Transformation", Math. Comp., 48 (1987), +-c pp 663-673. +-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +-c SIAM J. Matr. Anal. Apps., January (1993). +-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +-c for Updating the QR decomposition", ACM TOMS, December 1990, +-c Volume 16 Number 4, pp 369-377. +-c +-c\Remarks +-c 1. The converged Ritz values are always returned in increasing +-c (algebraic) order. +-c +-c 2. Currently only HOWMNY = 'A' is implemented. It is included at this +-c stage for the user who wants to incorporate it. +-c +-c\Routines called: +-c dsesrt ARPACK routine that sorts an array X, and applies the +-c corresponding permutation to a matrix A. +-c dsortr dsortr ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c dvout ARPACK utility routine that prints vectors. +-c dgeqr2 LAPACK routine that computes the QR factorization of +-c a matrix. +-c dlacpy LAPACK matrix copy routine. +-c dlamch LAPACK routine that determines machine constants. +-c dorm2r LAPACK routine that applies an orthogonal matrix in +-c factored form. +-c dsteqr LAPACK routine that computes eigenvalues and eigenvectors +-c of a tridiagonal matrix. +-c dger Level 2 BLAS rank one update to a matrix. +-c dcopy Level 1 BLAS that copies one vector to another . +-c dnrm2 Level 1 BLAS that computes the norm of a vector. +-c dscal Level 1 BLAS that scales a vector. +-c dswap Level 1 BLAS that swaps the contents of two vectors. +- +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +- subroutine dseupd (rvec , howmny, select, d , +- & z , ldz , sigma , bmat , +- & n , which , nev , tol , +- & resid , ncv , v , ldv , +- & iparam, ipntr , workd , workl, +- & lworkl, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat, howmny, which*2 +- logical rvec +- integer info, ldz, ldv, lworkl, n, ncv, nev +- Double precision +- & sigma, tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(7), ipntr(11) +- logical select(ncv) +- Double precision +- & d(nev) , resid(n) , v(ldv,ncv), +- & z(ldz, nev), workd(2*n), workl(lworkl) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0 , zero = 0.0D+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character type*6 +- integer bounds , ierr , ih , ihb , ihd , +- & iq , iw , j , k , ldh , +- & ldq , mode , msglvl, nconv , next , +- & ritz , irz , ibd , np , ishift, +- & leftptr, rghtptr, numcnv, jj +- Double precision +- & bnorm2 , rnorm, temp, temp1, eps23 +- logical reord +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dcopy , dger , dgeqr2 , dlacpy , dorm2r , dscal , +- & dsesrt , dsteqr , dswap , dvout , ivout , dsortr +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dnrm2 , dlamch +- external dnrm2 , dlamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic min +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- msglvl = mseupd +- mode = iparam(7) +- nconv = iparam(5) +- info = 0 +-c +-c %--------------% +-c | Quick return | +-c %--------------% +-c +- if (nconv .eq. 0) go to 9000 +- ierr = 0 +-c +- if (nconv .le. 0) ierr = -14 +- if (n .le. 0) ierr = -1 +- if (nev .le. 0) ierr = -2 +- if (ncv .le. nev .or. ncv .gt. n) ierr = -3 +- if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LA' .and. +- & which .ne. 'SA' .and. +- & which .ne. 'BE') ierr = -5 +- if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 +- if ( (howmny .ne. 'A' .and. +- & howmny .ne. 'P' .and. +- & howmny .ne. 'S') .and. rvec ) +- & ierr = -15 +- if (rvec .and. howmny .eq. 'S') ierr = -16 +-c +- if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 +-c +- if (mode .eq. 1 .or. mode .eq. 2) then +- type = 'REGULR' +- else if (mode .eq. 3 ) then +- type = 'SHIFTI' +- else if (mode .eq. 4 ) then +- type = 'BUCKLE' +- else if (mode .eq. 5 ) then +- type = 'CAYLEY' +- else +- ierr = -10 +- end if +- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +- if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- go to 9000 +- end if +-c +-c %-------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:2*ncv) := generated tridiagonal matrix H | +-c | The subdiagonal is stored in workl(2:ncv). | +-c | The dead spot is workl(1) but upon exiting | +-c | dsaupd stores the B-norm of the last residual | +-c | vector in workl(1). We use this !!! | +-c | workl(2*ncv+1:2*ncv+ncv) := ritz values | +-c | The wanted values are in the first NCONV spots. | +-c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | +-c | The wanted values are in the first NCONV spots. | +-c | NOTE: workl(1:4*ncv) is set by dsaupd and is not | +-c | modified by dseupd . | +-c %-------------------------------------------------------% +-c +-c %-------------------------------------------------------% +-c | The following is used and set by dseupd . | +-c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | +-c | computation of the eigenvectors of H. Stores | +-c | the diagonal of H. Upon EXIT contains the NCV | +-c | Ritz values of the original system. The first | +-c | NCONV spots have the wanted values. If MODE = | +-c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | +-c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | +-c | computation of the eigenvectors of H. Stores | +-c | the subdiagonal of H. Upon EXIT contains the | +-c | NCV corresponding Ritz estimates of the | +-c | original system. The first NCONV spots have the | +-c | wanted values. If MODE = 1,2 then will equal | +-c | workl(3*ncv+1:4*ncv). | +-c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | +-c | the eigenvector matrix for H as returned by | +-c | dsteqr . Not referenced if RVEC = .False. | +-c | Ordering follows that of workl(4*ncv+1:5*ncv) | +-c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | +-c | Workspace. Needed by dsteqr and by dseupd . | +-c | GRAND total of NCV*(NCV+8) locations. | +-c %-------------------------------------------------------% +-c +-c +- ih = ipntr(5) +- ritz = ipntr(6) +- bounds = ipntr(7) +- ldh = ncv +- ldq = ncv +- ihd = bounds + ldh +- ihb = ihd + ldh +- iq = ihb + ldh +- iw = iq + ldh*ncv +- next = iw + 2*ncv +- ipntr(4) = next +- ipntr(8) = ihd +- ipntr(9) = ihb +- ipntr(10) = iq +-c +-c %----------------------------------------% +-c | irz points to the Ritz values computed | +-c | by _seigt before exiting _saup2. | +-c | ibd points to the Ritz estimates | +-c | computed by _seigt before exiting | +-c | _saup2. | +-c %----------------------------------------% +-c +- irz = ipntr(11)+ncv +- ibd = irz+ncv +-c +-c +-c %---------------------------------% +-c | Set machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = dlamch ('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0 ) +-c +-c %---------------------------------------% +-c | RNORM is B-norm of the RESID(1:N). | +-c | BNORM2 is the 2 norm of B*RESID(1:N). | +-c | Upon exit of dsaupd WORKD(1:N) has | +-c | B*RESID(1:N). | +-c %---------------------------------------% +-c +- rnorm = workl(ih) +- if (bmat .eq. 'I') then +- bnorm2 = rnorm +- else if (bmat .eq. 'G') then +- bnorm2 = dnrm2 (n, workd, 1) +- end if +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, ncv, workl(irz), ndigit, +- & '_seupd: Ritz values passed in from _SAUPD.') +- call dvout (logfil, ncv, workl(ibd), ndigit, +- & '_seupd: Ritz estimates passed in from _SAUPD.') +- end if +-c +- if (rvec) then +-c +- reord = .false. +-c +-c %---------------------------------------------------% +-c | Use the temporary bounds array to store indices | +-c | These will be used to mark the select array later | +-c %---------------------------------------------------% +-c +- do 10 j = 1,ncv +- workl(bounds+j-1) = j +- select(j) = .false. +- 10 continue +-c +-c %-------------------------------------% +-c | Select the wanted Ritz values. | +-c | Sort the Ritz values so that the | +-c | wanted ones appear at the tailing | +-c | NEV positions of workl(irr) and | +-c | workl(iri). Move the corresponding | +-c | error estimates in workl(bound) | +-c | accordingly. | +-c %-------------------------------------% +-c +- np = ncv - nev +- ishift = 0 +- call dsgets (ishift, which , nev , +- & np , workl(irz) , workl(bounds), +- & workl) +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, ncv, workl(irz), ndigit, +- & '_seupd: Ritz values after calling _SGETS.') +- call dvout (logfil, ncv, workl(bounds), ndigit, +- & '_seupd: Ritz value indices after calling _SGETS.') +- end if +-c +-c %-----------------------------------------------------% +-c | Record indices of the converged wanted Ritz values | +-c | Mark the select array for possible reordering | +-c %-----------------------------------------------------% +-c +- numcnv = 0 +- do 11 j = 1,ncv +- temp1 = max(eps23, abs(workl(irz+ncv-j)) ) +- jj = workl(bounds + ncv - j) +- if (numcnv .lt. nconv .and. +- & workl(ibd+jj-1) .le. tol*temp1) then +- select(jj) = .true. +- numcnv = numcnv + 1 +- if (jj .gt. nconv) reord = .true. +- endif +- 11 continue +-c +-c %-----------------------------------------------------------% +-c | Check the count (numcnv) of converged Ritz values with | +-c | the number (nconv) reported by _saupd. If these two | +-c | are different then there has probably been an error | +-c | caused by incorrect passing of the _saupd data. | +-c %-----------------------------------------------------------% +-c +- if (msglvl .gt. 2) then +- call ivout(logfil, 1, [numcnv], ndigit, +- & '_seupd: Number of specified eigenvalues') +- call ivout(logfil, 1, [nconv], ndigit, +- & '_seupd: Number of "converged" eigenvalues') +- end if +-c +- if (numcnv .ne. nconv) then +- info = -17 +- go to 9000 +- end if +-c +-c %-----------------------------------------------------------% +-c | Call LAPACK routine _steqr to compute the eigenvalues and | +-c | eigenvectors of the final symmetric tridiagonal matrix H. | +-c | Initialize the eigenvector matrix Q to the identity. | +-c %-----------------------------------------------------------% +-c +- call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1) +- call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1) +-c +- call dsteqr ('Identity', ncv, workl(ihd), workl(ihb), +- & workl(iq) , ldq, workl(iw), ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 9000 +- end if +-c +- if (msglvl .gt. 1) then +- call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1) +- call dvout (logfil, ncv, workl(ihd), ndigit, +- & '_seupd: NCV Ritz values of the final H matrix') +- call dvout (logfil, ncv, workl(iw), ndigit, +- & '_seupd: last row of the eigenvector matrix for H') +- end if +-c +- if (reord) then +-c +-c %---------------------------------------------% +-c | Reordered the eigenvalues and eigenvectors | +-c | computed by _steqr so that the "converged" | +-c | eigenvalues appear in the first NCONV | +-c | positions of workl(ihd), and the associated | +-c | eigenvectors appear in the first NCONV | +-c | columns. | +-c %---------------------------------------------% +-c +- leftptr = 1 +- rghtptr = ncv +-c +- if (ncv .eq. 1) go to 30 +-c +- 20 if (select(leftptr)) then +-c +-c %-------------------------------------------% +-c | Search, from the left, for the first Ritz | +-c | value that has not converged. | +-c %-------------------------------------------% +-c +- leftptr = leftptr + 1 +-c +- else if ( .not. select(rghtptr)) then +-c +-c %----------------------------------------------% +-c | Search, from the right, the first Ritz value | +-c | that has converged. | +-c %----------------------------------------------% +-c +- rghtptr = rghtptr - 1 +-c +- else +-c +-c %----------------------------------------------% +-c | Swap the Ritz value on the left that has not | +-c | converged with the Ritz value on the right | +-c | that has converged. Swap the associated | +-c | eigenvector of the tridiagonal matrix H as | +-c | well. | +-c %----------------------------------------------% +-c +- temp = workl(ihd+leftptr-1) +- workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) +- workl(ihd+rghtptr-1) = temp +- call dcopy (ncv, workl(iq+ncv*(leftptr-1)), 1, +- & workl(iw), 1) +- call dcopy (ncv, workl(iq+ncv*(rghtptr-1)), 1, +- & workl(iq+ncv*(leftptr-1)), 1) +- call dcopy (ncv, workl(iw), 1, +- & workl(iq+ncv*(rghtptr-1)), 1) +- leftptr = leftptr + 1 +- rghtptr = rghtptr - 1 +-c +- end if +-c +- if (leftptr .lt. rghtptr) go to 20 +-c +- end if +-c +- 30 if (msglvl .gt. 2) then +- call dvout (logfil, ncv, workl(ihd), ndigit, +- & '_seupd: The eigenvalues of H--reordered') +- end if +-c +-c %----------------------------------------% +-c | Load the converged Ritz values into D. | +-c %----------------------------------------% +-c +- call dcopy (nconv, workl(ihd), 1, d, 1) +-c +- else +-c +-c %-----------------------------------------------------% +-c | Ritz vectors not required. Load Ritz values into D. | +-c %-----------------------------------------------------% +-c +- call dcopy (nconv, workl(ritz), 1, d, 1) +- call dcopy (ncv, workl(ritz), 1, workl(ihd), 1) +-c +- end if +-c +-c %------------------------------------------------------------------% +-c | Transform the Ritz values and possibly vectors and corresponding | +-c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | +-c | (and corresponding data) are returned in ascending order. | +-c %------------------------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +-c +-c %---------------------------------------------------------% +-c | Ascending sort of wanted Ritz values, vectors and error | +-c | bounds. Not necessary if only Ritz values are desired. | +-c %---------------------------------------------------------% +-c +- if (rvec) then +- call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) +- else +- call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) +- end if +-c +- else +-c +-c %-------------------------------------------------------------% +-c | * Make a copy of all the Ritz values. | +-c | * Transform the Ritz values back to the original system. | +-c | For TYPE = 'SHIFTI' the transformation is | +-c | lambda = 1/theta + sigma | +-c | For TYPE = 'BUCKLE' the transformation is | +-c | lambda = sigma * theta / ( theta - 1 ) | +-c | For TYPE = 'CAYLEY' the transformation is | +-c | lambda = sigma * (theta + 1) / (theta - 1 ) | +-c | where the theta are the Ritz values returned by dsaupd . | +-c | NOTES: | +-c | *The Ritz vectors are not affected by the transformation. | +-c | They are only reordered. | +-c %-------------------------------------------------------------% +-c +- call dcopy (ncv, workl(ihd), 1, workl(iw), 1) +- if (type .eq. 'SHIFTI') then +- do 40 k=1, ncv +- workl(ihd+k-1) = one / workl(ihd+k-1) + sigma +- 40 continue +- else if (type .eq. 'BUCKLE') then +- do 50 k=1, ncv +- workl(ihd+k-1) = sigma * workl(ihd+k-1) / +- & (workl(ihd+k-1) - one) +- 50 continue +- else if (type .eq. 'CAYLEY') then +- do 60 k=1, ncv +- workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / +- & (workl(ihd+k-1) - one) +- 60 continue +- end if +-c +-c %-------------------------------------------------------------% +-c | * Store the wanted NCONV lambda values into D. | +-c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | +-c | into ascending order and apply sort to the NCONV theta | +-c | values in the transformed system. We will need this to | +-c | compute Ritz estimates in the original system. | +-c | * Finally sort the lambda`s into ascending order and apply | +-c | to Ritz vectors if wanted. Else just sort lambda`s into | +-c | ascending order. | +-c | NOTES: | +-c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | +-c | match the ordering of the lambda. We`ll use them again for | +-c | Ritz vector purification. | +-c %-------------------------------------------------------------% +-c +- call dcopy (nconv, workl(ihd), 1, d, 1) +- call dsortr ('LA', .true., nconv, workl(ihd), workl(iw)) +- if (rvec) then +- call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) +- else +- call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) +- call dscal (ncv, bnorm2/rnorm, workl(ihb), 1) +- call dsortr ('LA', .true., nconv, d, workl(ihb)) +- end if +-c +- end if +-c +-c %------------------------------------------------% +-c | Compute the Ritz vectors. Transform the wanted | +-c | eigenvectors of the symmetric tridiagonal H by | +-c | the Lanczos basis matrix V. | +-c %------------------------------------------------% +-c +- if (rvec .and. howmny .eq. 'A') then +-c +-c %----------------------------------------------------------% +-c | Compute the QR factorization of the matrix representing | +-c | the wanted invariant subspace located in the first NCONV | +-c | columns of workl(iq,ldq). | +-c %----------------------------------------------------------% +-c +- call dgeqr2 (ncv, nconv , workl(iq) , +- & ldq, workl(iw+ncv), workl(ihb), +- & ierr) +-c +-c %--------------------------------------------------------% +-c | * Postmultiply V by Q. | +-c | * Copy the first NCONV columns of VQ into Z. | +-c | The N by NCONV matrix Z is now a matrix representation | +-c | of the approximate invariant subspace associated with | +-c | the Ritz values in workl(ihd). | +-c %--------------------------------------------------------% +-c +- call dorm2r ('Right', 'Notranspose', n , +- & ncv , nconv , workl(iq), +- & ldq , workl(iw+ncv), v , +- & ldv , workd(n+1) , ierr) +- call dlacpy ('All', n, nconv, v, ldv, z, ldz) +-c +-c %-----------------------------------------------------% +-c | In order to compute the Ritz estimates for the Ritz | +-c | values in both systems, need the last row of the | +-c | eigenvector matrix. Remember, it`s in factored form | +-c %-----------------------------------------------------% +-c +- do 65 j = 1, ncv-1 +- workl(ihb+j-1) = zero +- 65 continue +- workl(ihb+ncv-1) = one +- call dorm2r ('Left', 'Transpose' , ncv , +- & 1 , nconv , workl(iq) , +- & ldq , workl(iw+ncv), workl(ihb), +- & ncv , temp , ierr) +-c +-c %-----------------------------------------------------% +-c | Make a copy of the last row into | +-c | workl(iw+ncv:iw+2*ncv), as it is needed again in | +-c | the Ritz vector purification step below | +-c %-----------------------------------------------------% +-c +- do 67 j = 1, nconv +- workl(iw+ncv+j-1) = workl(ihb+j-1) +- 67 continue +- +- else if (rvec .and. howmny .eq. 'S') then +-c +-c Not yet implemented. See remark 2 above. +-c +- end if +-c +- if (type .eq. 'REGULR' .and. rvec) then +-c +- do 70 j=1, ncv +- workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) +- 70 continue +-c +- else if (type .ne. 'REGULR' .and. rvec) then +-c +-c %-------------------------------------------------% +-c | * Determine Ritz estimates of the theta. | +-c | If RVEC = .true. then compute Ritz estimates | +-c | of the theta. | +-c | If RVEC = .false. then copy Ritz estimates | +-c | as computed by dsaupd . | +-c | * Determine Ritz estimates of the lambda. | +-c %-------------------------------------------------% +-c +- call dscal (ncv, bnorm2, workl(ihb), 1) +- if (type .eq. 'SHIFTI') then +-c +- do 80 k=1, ncv +- workl(ihb+k-1) = abs( workl(ihb+k-1) ) +- & / workl(iw+k-1)**2 +- 80 continue +-c +- else if (type .eq. 'BUCKLE') then +-c +- do 90 k=1, ncv +- workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) +- & / (workl(iw+k-1)-one )**2 +- 90 continue +-c +- else if (type .eq. 'CAYLEY') then +-c +- do 100 k=1, ncv +- workl(ihb+k-1) = abs( workl(ihb+k-1) +- & / workl(iw+k-1)*(workl(iw+k-1)-one) ) +- 100 continue +-c +- end if +-c +- end if +-c +- if (type .ne. 'REGULR' .and. msglvl .gt. 1) then +- call dvout (logfil, nconv, d, ndigit, +- & '_seupd: Untransformed converged Ritz values') +- call dvout (logfil, nconv, workl(ihb), ndigit, +- & '_seupd: Ritz estimates of the untransformed Ritz values') +- else if (msglvl .gt. 1) then +- call dvout (logfil, nconv, d, ndigit, +- & '_seupd: Converged Ritz values') +- call dvout (logfil, nconv, workl(ihb), ndigit, +- & '_seupd: Associated Ritz estimates') +- end if +-c +-c %-------------------------------------------------% +-c | Ritz vector purification step. Formally perform | +-c | one of inverse subspace iteration. Only used | +-c | for MODE = 3,4,5. See reference 7 | +-c %-------------------------------------------------% +-c +- if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then +-c +- do 110 k=0, nconv-1 +- workl(iw+k) = workl(iw+ncv+k) +- & / workl(iw+k) +- 110 continue +-c +- else if (rvec .and. type .eq. 'BUCKLE') then +-c +- do 120 k=0, nconv-1 +- workl(iw+k) = workl(iw+ncv+k) +- & / (workl(iw+k)-one) +- 120 continue +-c +- end if +-c +- if (rvec .and. type .ne. 'REGULR') +- & call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of dseupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsgets.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsgets.f +deleted file mode 100644 +index 436a4fe848..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsgets.f ++++ /dev/null +@@ -1,219 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsgets +-c +-c\Description: +-c Given the eigenvalues of the symmetric tridiagonal matrix H, +-c computes the NP shifts AMU that are zeros of the polynomial of +-c degree NP which filters out components of the unwanted eigenvectors +-c corresponding to the AMU's based on some given criteria. +-c +-c NOTE: This is called even in the case of user specified shifts in +-c order to sort the eigenvalues, and error bounds of H for later use. +-c +-c\Usage: +-c call dsgets +-c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) +-c +-c\Arguments +-c ISHIFT Integer. (INPUT) +-c Method for selecting the implicit shifts at each iteration. +-c ISHIFT = 0: user specified shifts +-c ISHIFT = 1: exact shift with respect to the matrix H. +-c +-c WHICH Character*2. (INPUT) +-c Shift selection criteria. +-c 'LM' -> KEV eigenvalues of largest magnitude are retained. +-c 'SM' -> KEV eigenvalues of smallest magnitude are retained. +-c 'LA' -> KEV eigenvalues of largest value are retained. +-c 'SA' -> KEV eigenvalues of smallest value are retained. +-c 'BE' -> KEV eigenvalues, half from each end of the spectrum. +-c If KEV is odd, compute one more from the high end. +-c +-c KEV Integer. (INPUT) +-c KEV+NP is the size of the matrix H. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be computed. +-c +-c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT) +-c On INPUT, RITZ contains the eigenvalues of H. +-c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues +-c are in the first NP locations and the wanted part is in +-c the last KEV locations. When exact shifts are selected, the +-c unwanted part corresponds to the shifts to be applied. +-c +-c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) +-c Error bounds corresponding to the ordering in RITZ. +-c +-c SHIFTS Double precision array of length NP. (INPUT/OUTPUT) +-c On INPUT: contains the user specified shifts if ISHIFT = 0. +-c On OUTPUT: contains the shifts sorted into decreasing order +-c of magnitude with respect to the Ritz estimates contained in +-c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c dsortr ARPACK utility sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c dvout ARPACK utility routine that prints vectors. +-c dcopy Level 1 BLAS that copies one vector to another. +-c dswap Level 1 BLAS that swaps the contents of two vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/93: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\Remarks +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- integer ishift, kev, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & bounds(kev+np), ritz(kev+np), shifts(np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Double precision +- & one, zero +- parameter (one = 1.0D+0, zero = 0.0D+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer kevd2, msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external dswap, dcopy, dsortr, arscnd +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic max, min +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msgets +-c +- if (which .eq. 'BE') then +-c +-c %-----------------------------------------------------% +-c | Both ends of the spectrum are requested. | +-c | Sort the eigenvalues into algebraically increasing | +-c | order first then swap high end of the spectrum next | +-c | to low end in appropriate locations. | +-c | NOTE: when np < floor(kev/2) be careful not to swap | +-c | overlapping locations. | +-c %-----------------------------------------------------% +-c +- call dsortr ('LA', .true., kev+np, ritz, bounds) +- kevd2 = kev / 2 +- if ( kev .gt. 1 ) then +- call dswap ( min(kevd2,np), ritz, 1, +- & ritz( max(kevd2,np)+1 ), 1) +- call dswap ( min(kevd2,np), bounds, 1, +- & bounds( max(kevd2,np)+1 ), 1) +- end if +-c +- else +-c +-c %----------------------------------------------------% +-c | LM, SM, LA, SA case. | +-c | Sort the eigenvalues of H into the desired order | +-c | and apply the resulting order to BOUNDS. | +-c | The eigenvalues are sorted so that the wanted part | +-c | are always in the last KEV locations. | +-c %----------------------------------------------------% +-c +- call dsortr (which, .true., kev+np, ritz, bounds) +- end if +-c +- if (ishift .eq. 1 .and. np .gt. 0) then +-c +-c %-------------------------------------------------------% +-c | Sort the unwanted Ritz values used as shifts so that | +-c | the ones with largest Ritz estimates are first. | +-c | This will tend to minimize the effects of the | +-c | forward instability of the iteration when the shifts | +-c | are applied in subroutine dsapps. | +-c %-------------------------------------------------------% +-c +- call dsortr ('SM', .true., np, bounds, ritz) +- call dcopy (np, ritz, 1, shifts, 1) +- end if +-c +- call arscnd (t1) +- tsgets = tsgets + (t1 - t0) +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [kev], ndigit, '_sgets: KEV is') +- call ivout (logfil, 1, [np], ndigit, '_sgets: NP is') +- call dvout (logfil, kev+np, ritz, ndigit, +- & '_sgets: Eigenvalues of current H matrix') +- call dvout (logfil, kev+np, bounds, ndigit, +- & '_sgets: Associated Ritz estimates') +- end if +-c +- return +-c +-c %---------------% +-c | End of dsgets | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortc.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortc.f +deleted file mode 100644 +index 42baae2ba4..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortc.f ++++ /dev/null +@@ -1,344 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsortc +-c +-c\Description: +-c Sorts the complex array in XREAL and XIMAG into the order +-c specified by WHICH and optionally applies the permutation to the +-c real array Y. It is assumed that if an element of XIMAG is +-c nonzero, then its negative is also an element. In other words, +-c both members of a complex conjugate pair are to be sorted and the +-c pairs are kept adjacent to each other. +-c +-c\Usage: +-c call dsortc +-c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. +-c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. +-c 'LR' -> sort XREAL into increasing order of algebraic. +-c 'SR' -> sort XREAL into decreasing order of algebraic. +-c 'LI' -> sort XIMAG into increasing order of magnitude. +-c 'SI' -> sort XIMAG into decreasing order of magnitude. +-c NOTE: If an element of XIMAG is non-zero, then its negative +-c is also an element. +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to array Y. +-c APPLY = .FALSE. -> do not apply the sorted order to array Y. +-c +-c N Integer. (INPUT) +-c Size of the arrays. +-c +-c XREAL, Double precision array of length N. (INPUT/OUTPUT) +-c XIMAG Real and imaginary part of the array to be sorted. +-c +-c Y Double precision array of length N. (INPUT/OUTPUT) +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c Adapted from the sort routine in LANSO. +-c +-c\SCCS Information: @(#) +-c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsortc (which, apply, n, xreal, ximag, y) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & xreal(0:n-1), ximag(0:n-1), y(0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Double precision +- & temp, temp1, temp2 +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlapy2 +- external dlapy2 +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'LM') then +-c +-c %------------------------------------------------------% +-c | Sort XREAL,XIMAG into increasing order of magnitude. | +-c %------------------------------------------------------% +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +-c +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- temp1 = dlapy2(xreal(j),ximag(j)) +- temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) +-c +- if (temp1.gt.temp2) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 30 +- end if +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c %------------------------------------------------------% +-c | Sort XREAL,XIMAG into decreasing order of magnitude. | +-c %------------------------------------------------------% +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +-c +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j .lt. 0) go to 60 +-c +- temp1 = dlapy2(xreal(j),ximag(j)) +- temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) +-c +- if (temp1.lt.temp2) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into increasing order of algebraic. | +-c %------------------------------------------------% +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +-c +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (xreal(j).gt.xreal(j+igap)) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'SR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into decreasing order of algebraic. | +-c %------------------------------------------------% +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (xreal(j).lt.xreal(j+igap)) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +-c +- else if (which .eq. 'LI') then +-c +-c %------------------------------------------------% +-c | Sort XIMAG into increasing order of magnitude. | +-c %------------------------------------------------% +-c +- 130 continue +- if (igap .eq. 0) go to 9000 +- do 150 i = igap, n-1 +- j = i-igap +- 140 continue +-c +- if (j.lt.0) go to 150 +-c +- if (abs(ximag(j)).gt.abs(ximag(j+igap))) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 150 +- endif +- j = j-igap +- go to 140 +- 150 continue +- igap = igap / 2 +- go to 130 +-c +- else if (which .eq. 'SI') then +-c +-c %------------------------------------------------% +-c | Sort XIMAG into decreasing order of magnitude. | +-c %------------------------------------------------% +-c +- 160 continue +- if (igap .eq. 0) go to 9000 +- do 180 i = igap, n-1 +- j = i-igap +- 170 continue +-c +- if (j.lt.0) go to 180 +-c +- if (abs(ximag(j)).lt.abs(ximag(j+igap))) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 180 +- endif +- j = j-igap +- go to 170 +- 180 continue +- igap = igap / 2 +- go to 160 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dsortc | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortr.f +deleted file mode 100644 +index b44f916cf2..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dsortr.f ++++ /dev/null +@@ -1,218 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dsortr +-c +-c\Description: +-c Sort the array X1 in the order specified by WHICH and optionally +-c applies the permutation to the array X2. +-c +-c\Usage: +-c call dsortr +-c ( WHICH, APPLY, N, X1, X2 ) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> X1 is sorted into increasing order of magnitude. +-c 'SM' -> X1 is sorted into decreasing order of magnitude. +-c 'LA' -> X1 is sorted into increasing order of algebraic. +-c 'SA' -> X1 is sorted into decreasing order of algebraic. +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to X2. +-c APPLY = .FALSE. -> do not apply the sorted order to X2. +-c +-c N Integer. (INPUT) +-c Size of the arrays. +-c +-c X1 Double precision array of length N. (INPUT/OUTPUT) +-c The array to be sorted. +-c +-c X2 Double precision array of length N. (INPUT/OUTPUT) +-c Only referenced if APPLY = .TRUE. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/16/93: Version ' 2.1'. +-c Adapted from the sort routine in LANSO. +-c +-c\SCCS Information: @(#) +-c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dsortr (which, apply, n, x1, x2) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & x1(0:n-1), x2(0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Double precision +- & temp +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'SA') then +-c +-c X1 is sorted into decreasing order of algebraic. +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- if (x1(j).lt.x1(j+igap)) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 30 +- endif +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c X1 is sorted into decreasing order of magnitude. +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j.lt.0) go to 60 +-c +- if (abs(x1(j)).lt.abs(x1(j+igap))) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LA') then +-c +-c X1 is sorted into increasing order of algebraic. +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (x1(j).gt.x1(j+igap)) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'LM') then +-c +-c X1 is sorted into increasing order of magnitude. +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (abs(x1(j)).gt.abs(x1(j+igap))) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of dsortr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstatn.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstatn.f +deleted file mode 100644 +index d09d8a3713..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstatn.f ++++ /dev/null +@@ -1,61 +0,0 @@ +-c +-c %---------------------------------------------% +-c | Initialize statistic and timing information | +-c | for nonsymmetric Arnoldi code. | +-c %---------------------------------------------% +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 +-c +- subroutine dstatn +-c +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +-c +- include 'stat.h' +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- nopx = 0 +- nbx = 0 +- nrorth = 0 +- nitref = 0 +- nrstrt = 0 +-c +- tnaupd = 0.0D+0 +- tnaup2 = 0.0D+0 +- tnaitr = 0.0D+0 +- tneigh = 0.0D+0 +- tngets = 0.0D+0 +- tnapps = 0.0D+0 +- tnconv = 0.0D+0 +- titref = 0.0D+0 +- tgetv0 = 0.0D+0 +- trvec = 0.0D+0 +-c +-c %----------------------------------------------------% +-c | User time including reverse communication overhead | +-c %----------------------------------------------------% +-c +- tmvopx = 0.0D+0 +- tmvbx = 0.0D+0 +-c +- return +-c +-c +-c %---------------% +-c | End of dstatn | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstats.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstats.f +deleted file mode 100644 +index cb1b3f38dd..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstats.f ++++ /dev/null +@@ -1,47 +0,0 @@ +-c +-c\SCCS Information: @(#) +-c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 +-c %---------------------------------------------% +-c | Initialize statistic and timing information | +-c | for symmetric Arnoldi code. | +-c %---------------------------------------------% +- +- subroutine dstats +- +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +- include 'stat.h' +- +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +- +- nopx = 0 +- nbx = 0 +- nrorth = 0 +- nitref = 0 +- nrstrt = 0 +- +- tsaupd = 0.0D+0 +- tsaup2 = 0.0D+0 +- tsaitr = 0.0D+0 +- tseigt = 0.0D+0 +- tsgets = 0.0D+0 +- tsapps = 0.0D+0 +- tsconv = 0.0D+0 +- titref = 0.0D+0 +- tgetv0 = 0.0D+0 +- trvec = 0.0D+0 +- +-c %----------------------------------------------------% +-c | User time including reverse communication overhead | +-c %----------------------------------------------------% +- tmvopx = 0.0D+0 +- tmvbx = 0.0D+0 +- +- return +-c +-c End of dstats +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstqrb.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstqrb.f +deleted file mode 100644 +index d55a59a2d3..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/dstqrb.f ++++ /dev/null +@@ -1,594 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: dstqrb +-c +-c\Description: +-c Computes all eigenvalues and the last component of the eigenvectors +-c of a symmetric tridiagonal matrix using the implicit QL or QR method. +-c +-c This is mostly a modification of the LAPACK routine dsteqr. +-c See Remarks. +-c +-c\Usage: +-c call dstqrb +-c ( N, D, E, Z, WORK, INFO ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c The number of rows and columns in the matrix. N >= 0. +-c +-c D Double precision array, dimension (N). (INPUT/OUTPUT) +-c On entry, D contains the diagonal elements of the +-c tridiagonal matrix. +-c On exit, D contains the eigenvalues, in ascending order. +-c If an error exit is made, the eigenvalues are correct +-c for indices 1,2,...,INFO-1, but they are unordered and +-c may not be the smallest eigenvalues of the matrix. +-c +-c E Double precision array, dimension (N-1). (INPUT/OUTPUT) +-c On entry, E contains the subdiagonal elements of the +-c tridiagonal matrix in positions 1 through N-1. +-c On exit, E has been destroyed. +-c +-c Z Double precision array, dimension (N). (OUTPUT) +-c On exit, Z contains the last row of the orthonormal +-c eigenvector matrix of the symmetric tridiagonal matrix. +-c If an error exit is made, Z contains the last row of the +-c eigenvector matrix associated with the stored eigenvalues. +-c +-c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE) +-c Workspace used in accumulating the transformation for +-c computing the last components of the eigenvectors. +-c +-c INFO Integer. (OUTPUT) +-c = 0: normal return. +-c < 0: if INFO = -i, the i-th argument had an illegal value. +-c > 0: if INFO = +i, the i-th eigenvalue has not converged +-c after a total of 30*N iterations. +-c +-c\Remarks +-c 1. None. +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c daxpy Level 1 BLAS that computes a vector triad. +-c dcopy Level 1 BLAS that copies one vector to another. +-c dswap Level 1 BLAS that swaps the contents of two vectors. +-c lsame LAPACK character comparison routine. +-c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2 +-c symmetric matrix. +-c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric +-c matrix. +-c dlamch LAPACK routine that determines machine constants. +-c dlanst LAPACK routine that computes the norm of a matrix. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c dlartg LAPACK Givens rotation construction routine. +-c dlascl LAPACK routine for careful scaling of a matrix. +-c dlaset LAPACK matrix initialization routine. +-c dlasr LAPACK routine that applies an orthogonal transformation to +-c a matrix. +-c dlasrt LAPACK sorting routine. +-c dsteqr LAPACK routine that computes eigenvalues and eigenvectors +-c of a symmetric tridiagonal matrix. +-c xerbla LAPACK error handler routine. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c 1. Starting with version 2.5, this routine is a modified version +-c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, +-c only commented out and new lines inserted. +-c All lines commented out have "c$$$" at the beginning. +-c Note that the LAPACK version 1.0 subroutine SSTEQR contained +-c bugs. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine dstqrb ( n, d, e, z, work, info ) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer info, n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Double precision +- & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) +-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 maxit +- parameter ( maxit = 30 ) +-c .. +-c .. local scalars .. +- integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, +- & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, +- & nm1, nmaxit +- Double precision +- & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, +- & s, safmax, safmin, ssfmax, ssfmin, tst +-c .. +-c .. external functions .. +- logical lsame +- Double precision +- & dlamch, dlanst, dlapy2 +- external lsame, dlamch, dlanst, dlapy2 +-c .. +-c .. external subroutines .. +- external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr, +- & dlasrt, dswap, xerbla +-c .. +-c .. intrinsic functions .. +- intrinsic abs, max, sign, sqrt +-c .. +-c .. executable statements .. +-c +-c test the input parameters. +-c +- info = 0 +-c +-c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN +-c$$$ ICOMPZ = 0 +-c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN +-c$$$ ICOMPZ = 1 +-c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN +-c$$$ ICOMPZ = 2 +-c$$$ ELSE +-c$$$ ICOMPZ = -1 +-c$$$ END IF +-c$$$ IF( ICOMPZ.LT.0 ) THEN +-c$$$ INFO = -1 +-c$$$ ELSE IF( N.LT.0 ) THEN +-c$$$ INFO = -2 +-c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, +-c$$$ $ N ) ) ) THEN +-c$$$ INFO = -6 +-c$$$ END IF +-c$$$ IF( INFO.NE.0 ) THEN +-c$$$ CALL XERBLA( 'SSTEQR', -INFO ) +-c$$$ RETURN +-c$$$ END IF +-c +-c *** New starting with version 2.5 *** +-c +- icompz = 2 +-c ************************************* +-c +-c quick return if possible +-c +- if( n.eq.0 ) +- $ return +-c +- if( n.eq.1 ) then +- if( icompz.eq.2 ) z( 1 ) = one +- return +- end if +-c +-c determine the unit roundoff and over/underflow thresholds. +-c +- eps = dlamch( 'e' ) +- eps2 = eps**2 +- safmin = dlamch( 's' ) +- safmax = one / safmin +- ssfmax = sqrt( safmax ) / three +- ssfmin = sqrt( safmin ) / eps2 +-c +-c compute the eigenvalues and eigenvectors of the tridiagonal +-c matrix. +-c +-c$$ if( icompz.eq.2 ) +-c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- if ( icompz .eq. 2 ) then +- do 5 j = 1, n-1 +- z(j) = zero +- 5 continue +- z( n ) = one +- end if +-c ************************************* +-c +- nmaxit = n*maxit +- jtot = 0 +-c +-c determine where the matrix splits and choose ql or qr iteration +-c for each block, according to whether top or bottom diagonal +-c element is smaller. +-c +- l1 = 1 +- nm1 = n - 1 +-c +- 10 continue +- if( l1.gt.n ) +- $ go to 160 +- if( l1.gt.1 ) +- $ e( l1-1 ) = zero +- if( l1.le.nm1 ) then +- do 20 m = l1, nm1 +- tst = abs( e( m ) ) +- if( tst.eq.zero ) +- $ go to 30 +- if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ +- $ 1 ) ) ) )*eps ) then +- e( m ) = zero +- go to 30 +- end if +- 20 continue +- end if +- m = n +-c +- 30 continue +- l = l1 +- lsv = l +- lend = m +- lendsv = lend +- l1 = m + 1 +- if( lend.eq.l ) +- $ go to 10 +-c +-c scale submatrix in rows and columns l to lend +-c +- anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) +- iscale = 0 +- if( anorm.eq.zero ) +- $ go to 10 +- if( anorm.gt.ssfmax ) then +- iscale = 1 +- call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, +- $ info ) +- call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, +- $ info ) +- else if( anorm.lt.ssfmin ) then +- iscale = 2 +- call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, +- $ info ) +- call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, +- $ info ) +- end if +-c +-c choose between ql and qr iteration +-c +- if( abs( d( lend ) ).lt.abs( d( l ) ) ) then +- lend = lsv +- l = lendsv +- end if +-c +- if( lend.gt.l ) then +-c +-c ql iteration +-c +-c look for small subdiagonal element. +-c +- 40 continue +- if( l.ne.lend ) then +- lendm1 = lend - 1 +- do 50 m = l, lendm1 +- tst = abs( e( m ) )**2 +- if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ +- $ safmin )go to 60 +- 50 continue +- end if +-c +- m = lend +-c +- 60 continue +- if( m.lt.lend ) +- $ e( m ) = zero +- p = d( l ) +- if( m.eq.l ) +- $ go to 80 +-c +-c if remaining matrix is 2-by-2, use dlae2 or dlaev2 +-c to compute its eigensystem. +-c +- if( m.eq.l+1 ) then +- if( icompz.gt.0 ) then +- call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) +- work( l ) = c +- work( n-1+l ) = s +-c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), +-c$$$ $ work( n-1+l ), z( 1, l ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- tst = z(l+1) +- z(l+1) = c*tst - s*z(l) +- z(l) = s*tst + c*z(l) +-c ************************************* +- else +- call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) +- end if +- d( l ) = rt1 +- d( l+1 ) = rt2 +- e( l ) = zero +- l = l + 2 +- if( l.le.lend ) +- $ go to 40 +- go to 140 +- end if +-c +- if( jtot.eq.nmaxit ) +- $ go to 140 +- jtot = jtot + 1 +-c +-c form shift. +-c +- g = ( d( l+1 )-p ) / ( two*e( l ) ) +- r = dlapy2( g, one ) +- g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) +-c +- s = one +- c = one +- p = zero +-c +-c inner loop +-c +- mm1 = m - 1 +- do 70 i = mm1, l, -1 +- f = s*e( i ) +- b = c*e( i ) +- call dlartg( g, f, c, s, r ) +- if( i.ne.m-1 ) +- $ e( i+1 ) = r +- g = d( i+1 ) - p +- r = ( d( i )-g )*s + two*c*b +- p = s*r +- d( i+1 ) = g + p +- g = c*r - b +-c +-c if eigenvectors are desired, then save rotations. +-c +- if( icompz.gt.0 ) then +- work( i ) = c +- work( n-1+i ) = -s +- end if +-c +- 70 continue +-c +-c if eigenvectors are desired, then apply saved rotations. +-c +- if( icompz.gt.0 ) then +- mm = m - l + 1 +-c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), +-c$$$ $ z( 1, l ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- call dlasr( 'r', 'v', 'b', 1, mm, work( l ), +- & work( n-1+l ), z( l ), 1 ) +-c ************************************* +- end if +-c +- d( l ) = d( l ) - p +- e( l ) = g +- go to 40 +-c +-c eigenvalue found. +-c +- 80 continue +- d( l ) = p +-c +- l = l + 1 +- if( l.le.lend ) +- $ go to 40 +- go to 140 +-c +- else +-c +-c qr iteration +-c +-c look for small superdiagonal element. +-c +- 90 continue +- if( l.ne.lend ) then +- lendp1 = lend + 1 +- do 100 m = l, lendp1, -1 +- tst = abs( e( m-1 ) )**2 +- if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ +- $ safmin )go to 110 +- 100 continue +- end if +-c +- m = lend +-c +- 110 continue +- if( m.gt.lend ) +- $ e( m-1 ) = zero +- p = d( l ) +- if( m.eq.l ) +- $ go to 130 +-c +-c if remaining matrix is 2-by-2, use dlae2 or dlaev2 +-c to compute its eigensystem. +-c +- if( m.eq.l-1 ) then +- if( icompz.gt.0 ) then +- call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) +-c$$$ work( m ) = c +-c$$$ work( n-1+m ) = s +-c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), +-c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- tst = z(l) +- z(l) = c*tst - s*z(l-1) +- z(l-1) = s*tst + c*z(l-1) +-c ************************************* +- else +- call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) +- end if +- d( l-1 ) = rt1 +- d( l ) = rt2 +- e( l-1 ) = zero +- l = l - 2 +- if( l.ge.lend ) +- $ go to 90 +- go to 140 +- end if +-c +- if( jtot.eq.nmaxit ) +- $ go to 140 +- jtot = jtot + 1 +-c +-c form shift. +-c +- g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) +- r = dlapy2( g, one ) +- g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) +-c +- s = one +- c = one +- p = zero +-c +-c inner loop +-c +- lm1 = l - 1 +- do 120 i = m, lm1 +- f = s*e( i ) +- b = c*e( i ) +- call dlartg( g, f, c, s, r ) +- if( i.ne.m ) +- $ e( i-1 ) = r +- g = d( i ) - p +- r = ( d( i+1 )-g )*s + two*c*b +- p = s*r +- d( i ) = g + p +- g = c*r - b +-c +-c if eigenvectors are desired, then save rotations. +-c +- if( icompz.gt.0 ) then +- work( i ) = c +- work( n-1+i ) = s +- end if +-c +- 120 continue +-c +-c if eigenvectors are desired, then apply saved rotations. +-c +- if( icompz.gt.0 ) then +- mm = l - m + 1 +-c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), +-c$$$ $ z( 1, m ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), +- & z( m ), 1 ) +-c ************************************* +- end if +-c +- d( l ) = d( l ) - p +- e( lm1 ) = g +- go to 90 +-c +-c eigenvalue found. +-c +- 130 continue +- d( l ) = p +-c +- l = l - 1 +- if( l.ge.lend ) +- $ go to 90 +- go to 140 +-c +- end if +-c +-c undo scaling if necessary +-c +- 140 continue +- if( iscale.eq.1 ) then +- call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, +- $ d( lsv ), n, info ) +- call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), +- $ n, info ) +- else if( iscale.eq.2 ) then +- call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, +- $ d( lsv ), n, info ) +- call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), +- $ n, info ) +- end if +-c +-c check for no convergence to an eigenvalue after a total +-c of n*maxit iterations. +-c +- if( jtot.lt.nmaxit ) +- $ go to 10 +- do 150 i = 1, n - 1 +- if( e( i ).ne.zero ) +- $ info = info + 1 +- 150 continue +- go to 190 +-c +-c order eigenvalues and eigenvectors. +-c +- 160 continue +- if( icompz.eq.0 ) then +-c +-c use quick sort +-c +- call dlasrt( 'i', n, d, info ) +-c +- else +-c +-c use selection sort to minimize swaps of eigenvectors +-c +- do 180 ii = 2, n +- i = ii - 1 +- k = i +- p = d( i ) +- do 170 j = ii, n +- if( d( j ).lt.p ) then +- k = j +- p = d( j ) +- end if +- 170 continue +- if( k.ne.i ) then +- d( k ) = d( i ) +- d( i ) = p +-c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) +-c *** New starting with version 2.5 *** +-c +- p = z(k) +- z(k) = z(i) +- z(i) = p +-c ************************************* +- end if +- 180 continue +- end if +-c +- 190 continue +- return +-c +-c %---------------% +-c | End of dstqrb | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sgetv0.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sgetv0.f +deleted file mode 100644 +index d861b2d6d7..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sgetv0.f ++++ /dev/null +@@ -1,421 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: sgetv0 +-c +-c\Description: +-c Generate a random initial residual vector for the Arnoldi process. +-c Force the residual vector to be in the range of the operator OP. +-c +-c\Usage: +-c call sgetv0 +-c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, +-c IPNTR, WORKD, IERR ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to sgetv0. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B in the (generalized) +-c eigenvalue problem A*x = lambda*B*x. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c ITRY Integer. (INPUT) +-c ITRY counts the number of times that sgetv0 is called. +-c It should be set to 1 on the initial call to sgetv0. +-c +-c INITV Logical variable. (INPUT) +-c .TRUE. => the initial residual vector is given in RESID. +-c .FALSE. => generate a random initial residual vector. +-c +-c N Integer. (INPUT) +-c Dimension of the problem. +-c +-c J Integer. (INPUT) +-c Index of the residual vector to be generated, with respect to +-c the Arnoldi process. J > 1 in case of a "restart". +-c +-c V Real N by J array. (INPUT) +-c The first J-1 columns of V contain the current Arnoldi basis +-c if this is a "restart". +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c RESID Real array of length N. (INPUT/OUTPUT) +-c Initial residual vector to be generated. If RESID is +-c provided, force RESID into the range of the operator OP. +-c +-c RNORM Real scalar. (OUTPUT) +-c B-norm of the generated residual. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c +-c WORKD Real work array of length 2*N. (REVERSE COMMUNICATION). +-c On exit, WORK(1:N) = B*RESID to be used in SSAITR. +-c +-c IERR Integer. (OUTPUT) +-c = 0: Normal exit. +-c = -1: Cannot generate a nontrivial restarted residual vector +-c in the range of the operator OP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine for vector output. +-c slarnv LAPACK routine for generating a random vector. +-c sgemv Level 2 BLAS routine for matrix vector multiplication. +-c scopy Level 1 BLAS that copies one vector to another. +-c sdot Level 1 BLAS that computes the scalar product of two vectors. +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine sgetv0 +- & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, +- & ipntr, workd, ierr ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- logical initv +- integer ido, ierr, itry, j, ldv, n +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Real +- & resid(n), v(ldv,j), workd(2*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical first, inits, orth +- integer idist, iseed(4), iter, msglvl, jj +- Real +- & rnorm0 +- save first, iseed, inits, iter, msglvl, orth, rnorm0 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external slarnv, svout, scopy, sgemv, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & sdot, snrm2 +- external sdot, snrm2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs, sqrt +-c +-c %-----------------% +-c | Data Statements | +-c %-----------------% +-c +- data inits /.true./ +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c +-c %-----------------------------------% +-c | Initialize the seed of the LAPACK | +-c | random number generator | +-c %-----------------------------------% +-c +- if (inits) then +- iseed(1) = 1 +- iseed(2) = 3 +- iseed(3) = 5 +- iseed(4) = 7 +- inits = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mgetv0 +-c +- ierr = 0 +- iter = 0 +- first = .FALSE. +- orth = .FALSE. +-c +-c %-----------------------------------------------------% +-c | Possibly generate a random starting vector in RESID | +-c | Use a LAPACK random number generator used by the | +-c | matrix generation routines. | +-c | idist = 1: uniform (0,1) distribution; | +-c | idist = 2: uniform (-1,1) distribution; | +-c | idist = 3: normal (0,1) distribution; | +-c %-----------------------------------------------------% +-c +- if (.not.initv) then +- idist = 2 +- call slarnv (idist, iseed, n, resid) +- end if +-c +-c %----------------------------------------------------------% +-c | Force the starting vector into the range of OP to handle | +-c | the generalized problem when B is possibly (singular). | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (itry .eq. 1) then +- nopx = nopx + 1 +- ipntr(1) = 1 +- ipntr(2) = n + 1 +- call scopy (n, resid, 1, workd, 1) +- ido = -1 +- go to 9000 +- else if (itry .gt. 1 .and. bmat .eq. 'G') then +- call scopy (n, resid, 1, workd(n + 1), 1) +- end if +- end if +-c +-c %-----------------------------------------% +-c | Back from computing OP*(initial-vector) | +-c %-----------------------------------------% +-c +- if (first) go to 20 +-c +-c %-----------------------------------------------% +-c | Back from computing OP*(orthogonalized-vector) | +-c %-----------------------------------------------% +-c +- if (orth) go to 40 +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +- end if +-c +-c %------------------------------------------------------% +-c | Starting vector is now in the range of OP; r = OP*r; | +-c | Compute B-norm of starting vector. | +-c %------------------------------------------------------% +-c +- call arscnd (t2) +- first = .TRUE. +- if (itry .eq. 1) call scopy (n, workd(n + 1), 1, resid, 1) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd, 1) +- end if +-c +- 20 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- first = .FALSE. +- if (bmat .eq. 'G') then +- rnorm0 = sdot (n, resid, 1, workd, 1) +- rnorm0 = sqrt(abs(rnorm0)) +- else if (bmat .eq. 'I') then +- rnorm0 = snrm2(n, resid, 1) +- end if +- rnorm = rnorm0 +-c +-c %---------------------------------------------% +-c | Exit if this is the very first Arnoldi step | +-c %---------------------------------------------% +-c +- if (j .eq. 1) go to 50 +-c +-c %---------------------------------------------------------------- +-c | Otherwise need to B-orthogonalize the starting vector against | +-c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | +-c | This is the case where an invariant subspace is encountered | +-c | in the middle of the Arnoldi factorization. | +-c | | +-c | s = V^{T}*B*r; r = r - V*s; | +-c | | +-c | Stopping criteria used for iter. ref. is discussed in | +-c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | +-c %---------------------------------------------------------------% +-c +- orth = .TRUE. +- 30 continue +-c +- call sgemv ('T', n, j-1, one, v, ldv, workd, 1, +- & zero, workd(n+1), 1) +- call sgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, +- & one, resid, 1) +-c +-c %----------------------------------------------------------% +-c | Compute the B-norm of the orthogonalized starting vector | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd, 1) +- end if +-c +- 40 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- rnorm = sdot (n, resid, 1, workd, 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = snrm2(n, resid, 1) +- end if +-c +-c %--------------------------------------% +-c | Check for further orthogonalization. | +-c %--------------------------------------% +-c +- if (msglvl .gt. 2) then +- call svout (logfil, 1, [rnorm0], ndigit, +- & '_getv0: re-orthonalization ; rnorm0 is') +- call svout (logfil, 1, [rnorm], ndigit, +- & '_getv0: re-orthonalization ; rnorm is') +- end if +-c +- if (rnorm .gt. 0.717*rnorm0) go to 50 +-c +- iter = iter + 1 +- if (iter .le. 5) then +-c +-c %-----------------------------------% +-c | Perform iterative refinement step | +-c %-----------------------------------% +-c +- rnorm0 = rnorm +- go to 30 +- else +-c +-c %------------------------------------% +-c | Iterative refinement step "failed" | +-c %------------------------------------% +-c +- do 45 jj = 1, n +- resid(jj) = zero +- 45 continue +- rnorm = zero +- ierr = -1 +- end if +-c +- 50 continue +-c +- if (msglvl .gt. 0) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_getv0: B-norm of initial / restarted starting vector') +- end if +- if (msglvl .gt. 3) then +- call svout (logfil, n, resid, ndigit, +- & '_getv0: initial / restarted starting vector') +- end if +- ido = 99 +-c +- call arscnd (t1) +- tgetv0 = tgetv0 + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of sgetv0 | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaitr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaitr.f +deleted file mode 100644 +index 8a5d795be3..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaitr.f ++++ /dev/null +@@ -1,840 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: snaitr +-c +-c\Description: +-c Reverse communication interface for applying NP additional steps to +-c a K step nonsymmetric Arnoldi factorization. +-c +-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +-c +-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +-c +-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +-c +-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +-c +-c where OP and B are as in snaupd. The B-norm of r_{k+p} is also +-c computed and returned. +-c +-c\Usage: +-c call snaitr +-c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c This is for the restart phase to force the new +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y, +-c IPNTR(3) is the pointer into WORK for B * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c When the routine is used in the "shift-and-invert" mode, the +-c vector B * Q is already available and do not need to be +-c recompute in forming OP * Q. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. See snaupd. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c K Integer. (INPUT) +-c Current size of V and H. +-c +-c NP Integer. (INPUT) +-c Number of additional Arnoldi steps to take. +-c +-c NB Integer. (INPUT) +-c Blocksize to be used in the recurrence. +-c Only work for NB = 1 right now. The goal is to have a +-c program that implement both the block and non-block method. +-c +-c RESID Real array of length N. (INPUT/OUTPUT) +-c On INPUT: RESID contains the residual vector r_{k}. +-c On OUTPUT: RESID contains the residual vector r_{k+p}. +-c +-c RNORM Real scalar. (INPUT/OUTPUT) +-c B-norm of the starting residual on input. +-c B-norm of the updated residual r_{k+p} on output. +-c +-c V Real N by K+NP array. (INPUT/OUTPUT) +-c On INPUT: V contains the Arnoldi vectors in the first K +-c columns. +-c On OUTPUT: V contains the new NP Arnoldi vectors in the next +-c NP columns. The first K columns are unchanged. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Real (K+NP) by (K+NP) array. (INPUT/OUTPUT) +-c H is used to store the generated upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORK for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The calling program should not +-c use WORKD as temporary workspace during the iteration !!!!!! +-c On input, WORKD(1:N) = B*RESID and is used to save some +-c computation at the first step. +-c +-c INFO Integer. (OUTPUT) +-c = 0: Normal exit. +-c > 0: Size of the spanning invariant subspace of OP found. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c sgetv0 ARPACK routine to generate the initial vector. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c smout ARPACK utility routine that prints matrices +-c svout ARPACK utility routine that prints vectors. +-c slabad LAPACK routine that computes machine constants. +-c slamch LAPACK routine that determines machine constants. +-c slascl LAPACK routine for careful scaling of a matrix. +-c slanhs LAPACK routine that computes various norms of a matrix. +-c sgemv Level 2 BLAS routine for matrix vector multiplication. +-c saxpy Level 1 BLAS that computes a vector triad. +-c sscal Level 1 BLAS that scales a vector. +-c scopy Level 1 BLAS that copies one vector to another . +-c sdot Level 1 BLAS that computes the scalar product of two vectors. +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c The algorithm implemented is: +-c +-c restart = .false. +-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +-c r_{k} contains the initial residual vector even for k = 0; +-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +-c computed by the calling program. +-c +-c betaj = rnorm ; p_{k+1} = B*r_{k} ; +-c For j = k+1, ..., k+np Do +-c 1) if ( betaj < tol ) stop or restart depending on j. +-c ( At present tol is zero ) +-c if ( restart ) generate a new starting vector. +-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +-c p_{j} = p_{j}/betaj +-c 3) r_{j} = OP*v_{j} where OP is defined as in snaupd +-c For shift-invert mode p_{j} = B*v_{j} is already available. +-c wnorm = || OP*v_{j} || +-c 4) Compute the j-th step residual vector. +-c w_{j} = V_{j}^T * B * OP * v_{j} +-c r_{j} = OP*v_{j} - V_{j} * w_{j} +-c H(:,j) = w_{j}; +-c H(j,j-1) = rnorm +-c rnorm = || r_(j) || +-c If (rnorm > 0.717*wnorm) accept step and go back to 1) +-c 5) Re-orthogonalization step: +-c s = V_{j}'*B*r_{j} +-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +-c alphaj = alphaj + s_{j}; +-c 6) Iterative refinement step: +-c If (rnorm1 > 0.717*rnorm) then +-c rnorm = rnorm1 +-c accept step and go back to 1) +-c Else +-c rnorm = rnorm1 +-c If this is the first time in step 6), go to 5) +-c Else r_{j} lies in the span of V_{j} numerically. +-c Set r_{j} = 0 and rnorm = 0; go to 1) +-c EndIf +-c End Do +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine snaitr +- & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, +- & ipntr, workd, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- integer ido, info, k, ldh, ldv, n, nb, np +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Real +- & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical first, orth1, orth2, rstart, step3, step4 +- integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, +- & jj +- Real +- & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, +- & wnorm +- save first, orth1, orth2, rstart, step3, step4, +- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, +- & betaj, rnorm1, smlnum, ulp, unfl, wnorm +-c +-c %-----------------------% +-c | Local Array Arguments | +-c %-----------------------% +-c +- Real +- & xtemp(2) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external saxpy, scopy, sscal, sgemv, sgetv0, slabad, +- & svout, smout, ivout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & sdot, snrm2, slanhs, slamch +- external sdot, snrm2, slanhs, slamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs, sqrt +-c +-c %-----------------% +-c | Data statements | +-c %-----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------% +-c | Set machine-dependent constants for the | +-c | the splitting and deflation criterion. | +-c | If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine slahqr | +-c %-----------------------------------------% +-c +- unfl = slamch( 'safe minimum' ) +- ovfl = one / unfl +- call slabad( unfl, ovfl ) +- ulp = slamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mnaitr +-c +-c %------------------------------% +-c | Initial call to this routine | +-c %------------------------------% +-c +- info = 0 +- step3 = .false. +- step4 = .false. +- rstart = .false. +- orth1 = .false. +- orth2 = .false. +- j = k + 1 +- ipj = 1 +- irj = ipj + n +- ivj = irj + n +- end if +-c +-c %-------------------------------------------------% +-c | When in reverse communication mode one of: | +-c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +-c | will be .true. when .... | +-c | STEP3: return from computing OP*v_{j}. | +-c | STEP4: return from computing B-norm of OP*v_{j} | +-c | ORTH1: return from computing B-norm of r_{j+1} | +-c | ORTH2: return from computing B-norm of | +-c | correction to the residual vector. | +-c | RSTART: return from OP computations needed by | +-c | sgetv0. | +-c %-------------------------------------------------% +-c +- if (step3) go to 50 +- if (step4) go to 60 +- if (orth1) go to 70 +- if (orth2) go to 90 +- if (rstart) go to 30 +-c +-c %-----------------------------% +-c | Else this is the first step | +-c %-----------------------------% +-c +-c %--------------------------------------------------------------% +-c | | +-c | A R N O L D I I T E R A T I O N L O O P | +-c | | +-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +-c %--------------------------------------------------------------% +- +- 1000 continue +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: generating Arnoldi vector number') +- call svout (logfil, 1, [rnorm], ndigit, +- & '_naitr: B-norm of the current residual is') +- end if +-c +-c %---------------------------------------------------% +-c | STEP 1: Check if the B norm of j-th residual | +-c | vector is zero. Equivalent to determining whether | +-c | an exact j-step Arnoldi factorization is present. | +-c %---------------------------------------------------% +-c +- betaj = rnorm +- if (rnorm .gt. zero) go to 40 +-c +-c %---------------------------------------------------% +-c | Invariant subspace found, generate a new starting | +-c | vector which is orthogonal to the current Arnoldi | +-c | basis and continue the iteration. | +-c %---------------------------------------------------% +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: ****** RESTART AT STEP ******') +- end if +-c +-c %---------------------------------------------% +-c | ITRY is the loop variable that controls the | +-c | maximum amount of times that a restart is | +-c | attempted. NRSTRT is used by stat.h | +-c %---------------------------------------------% +-c +- betaj = zero +- nrstrt = nrstrt + 1 +- itry = 1 +- 20 continue +- rstart = .true. +- ido = 0 +- 30 continue +-c +-c %--------------------------------------% +-c | If in reverse communication mode and | +-c | RSTART = .true. flow returns here. | +-c %--------------------------------------% +-c +- call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, +- & resid, rnorm, ipntr, workd, ierr) +- if (ido .ne. 99) go to 9000 +- if (ierr .lt. 0) then +- itry = itry + 1 +- if (itry .le. 3) go to 20 +-c +-c %------------------------------------------------% +-c | Give up after several restart attempts. | +-c | Set INFO to the size of the invariant subspace | +-c | which spans OP and exit. | +-c %------------------------------------------------% +-c +- info = j - 1 +- call arscnd (t1) +- tnaitr = tnaitr + (t1 - t0) +- ido = 99 +- go to 9000 +- end if +-c +- 40 continue +-c +-c %---------------------------------------------------------% +-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +-c | when reciprocating a small RNORM, test against lower | +-c | machine bound. | +-c %---------------------------------------------------------% +-c +- call scopy (n, resid, 1, v(1,j), 1) +- if (rnorm .ge. unfl) then +- temp1 = one / rnorm +- call sscal (n, temp1, v(1,j), 1) +- call sscal (n, temp1, workd(ipj), 1) +- else +-c +-c %-----------------------------------------% +-c | To scale both v_{j} and p_{j} carefully | +-c | use LAPACK routine SLASCL | +-c %-----------------------------------------% +-c +- call slascl ('General', i, i, rnorm, one, n, 1, +- & v(1,j), n, infol) +- call slascl ('General', i, i, rnorm, one, n, 1, +- & workd(ipj), n, infol) +- end if +-c +-c %------------------------------------------------------% +-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +-c | Note that this is not quite yet r_{j}. See STEP 4 | +-c %------------------------------------------------------% +-c +- step3 = .true. +- nopx = nopx + 1 +- call arscnd (t2) +- call scopy (n, v(1,j), 1, workd(ivj), 1) +- ipntr(1) = ivj +- ipntr(2) = irj +- ipntr(3) = ipj +- ido = 1 +-c +-c %-----------------------------------% +-c | Exit in order to compute OP*v_{j} | +-c %-----------------------------------% +-c +- go to 9000 +- 50 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | +-c | if step3 = .true. | +-c %----------------------------------% +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +- +- step3 = .false. +-c +-c %------------------------------------------% +-c | Put another copy of OP*v_{j} into RESID. | +-c %------------------------------------------% +-c +- call scopy (n, workd(irj), 1, resid, 1) +-c +-c %---------------------------------------% +-c | STEP 4: Finish extending the Arnoldi | +-c | factorization to length j. | +-c %---------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- step4 = .true. +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-------------------------------------% +-c | Exit in order to compute B*OP*v_{j} | +-c %-------------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd(ipj), 1) +- end if +- 60 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | +-c | if step4 = .true. | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- step4 = .false. +-c +-c %-------------------------------------% +-c | The following is needed for STEP 5. | +-c | Compute the B-norm of OP*v_{j}. | +-c %-------------------------------------% +-c +- if (bmat .eq. 'G') then +- wnorm = sdot (n, resid, 1, workd(ipj), 1) +- wnorm = sqrt(abs(wnorm)) +- else if (bmat .eq. 'I') then +- wnorm = snrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------% +-c | Compute the j-th residual corresponding | +-c | to the j step factorization. | +-c | Use Classical Gram Schmidt and compute: | +-c | w_{j} <- V_{j}^T * B * OP * v_{j} | +-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +-c %-----------------------------------------% +-c +-c +-c %------------------------------------------% +-c | Compute the j Fourier coefficients w_{j} | +-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +-c %------------------------------------------% +-c +- call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, +- & zero, h(1,j), 1) +-c +-c %--------------------------------------% +-c | Orthogonalize r_{j} against V_{j}. | +-c | RESID contains OP*v_{j}. See STEP 3. | +-c %--------------------------------------% +-c +- call sgemv ('N', n, j, -one, v, ldv, h(1,j), 1, +- & one, resid, 1) +-c +- if (j .gt. 1) h(j,j-1) = betaj +-c +- call arscnd (t4) +-c +- orth1 = .true. +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*r_{j} | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd(ipj), 1) +- end if +- 70 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH1 = .true. | +-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- orth1 = .false. +-c +-c %------------------------------% +-c | Compute the B-norm of r_{j}. | +-c %------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm = sdot (n, resid, 1, workd(ipj), 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = snrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------------------------% +-c | STEP 5: Re-orthogonalization / Iterative refinement phase | +-c | Maximum NITER_ITREF tries. | +-c | | +-c | s = V_{j}^T * B * r_{j} | +-c | r_{j} = r_{j} - V_{j}*s | +-c | alphaj = alphaj + s_{j} | +-c | | +-c | The stopping criteria used for iterative refinement is | +-c | discussed in Parlett's book SEP, page 107 and in Gragg & | +-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +-c | Determine if we need to correct the residual. The goal is | +-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +-c | The following test determines whether the sine of the | +-c | angle between OP*x and the computed residual is less | +-c | than or equal to 0.717. | +-c %-----------------------------------------------------------% +-c +- if (rnorm .gt. 0.717*wnorm) go to 100 +- iter = 0 +- nrorth = nrorth + 1 +-c +-c %---------------------------------------------------% +-c | Enter the Iterative refinement phase. If further | +-c | refinement is necessary, loop back here. The loop | +-c | variable is ITER. Perform a step of Classical | +-c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +-c %---------------------------------------------------% +-c +- 80 continue +-c +- if (msglvl .gt. 2) then +- xtemp(1) = wnorm +- xtemp(2) = rnorm +- call svout (logfil, 2, xtemp, ndigit, +- & '_naitr: re-orthonalization; wnorm and rnorm are') +- call svout (logfil, j, h(1,j), ndigit, +- & '_naitr: j-th column of H') +- end if +-c +-c %----------------------------------------------------% +-c | Compute V_{j}^T * B * r_{j}. | +-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +-c %----------------------------------------------------% +-c +- call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, +- & zero, workd(irj), 1) +-c +-c %---------------------------------------------% +-c | Compute the correction to the residual: | +-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +-c | The correction to H is v(:,1:J)*H(1:J,1:J) | +-c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | +-c %---------------------------------------------% +-c +- call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, +- & one, resid, 1) +- call saxpy (j, one, workd(irj), 1, h(1,j), 1) +-c +- orth2 = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-----------------------------------% +-c | Exit in order to compute B*r_{j}. | +-c | r_{j} is the corrected residual. | +-c %-----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd(ipj), 1) +- end if +- 90 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH2 = .true. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +-c %-----------------------------------------------------% +-c | Compute the B-norm of the corrected residual r_{j}. | +-c %-----------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm1 = sdot (n, resid, 1, workd(ipj), 1) +- rnorm1 = sqrt(abs(rnorm1)) +- else if (bmat .eq. 'I') then +- rnorm1 = snrm2(n, resid, 1) +- end if +-c +- if (msglvl .gt. 0 .and. iter .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: Iterative refinement for Arnoldi residual') +- if (msglvl .gt. 2) then +- xtemp(1) = rnorm +- xtemp(2) = rnorm1 +- call svout (logfil, 2, xtemp, ndigit, +- & '_naitr: iterative refinement ; rnorm and rnorm1 are') +- end if +- end if +-c +-c %-----------------------------------------% +-c | Determine if we need to perform another | +-c | step of re-orthogonalization. | +-c %-----------------------------------------% +-c +- if (rnorm1 .gt. 0.717*rnorm) then +-c +-c %---------------------------------------% +-c | No need for further refinement. | +-c | The cosine of the angle between the | +-c | corrected residual vector and the old | +-c | residual vector is greater than 0.717 | +-c | In other words the corrected residual | +-c | and the old residual vector share an | +-c | angle of less than arcCOS(0.717) | +-c %---------------------------------------% +-c +- rnorm = rnorm1 +-c +- else +-c +-c %-------------------------------------------% +-c | Another step of iterative refinement step | +-c | is required. NITREF is used by stat.h | +-c %-------------------------------------------% +-c +- nitref = nitref + 1 +- rnorm = rnorm1 +- iter = iter + 1 +- if (iter .le. 1) go to 80 +-c +-c %-------------------------------------------------% +-c | Otherwise RESID is numerically in the span of V | +-c %-------------------------------------------------% +-c +- do 95 jj = 1, n +- resid(jj) = zero +- 95 continue +- rnorm = zero +- end if +-c +-c %----------------------------------------------% +-c | Branch here directly if iterative refinement | +-c | wasn't necessary or after at most NITER_REF | +-c | steps of iterative refinement. | +-c %----------------------------------------------% +-c +- 100 continue +-c +- rstart = .false. +- orth2 = .false. +-c +- call arscnd (t5) +- titref = titref + (t5 - t4) +-c +-c %------------------------------------% +-c | STEP 6: Update j = j+1; Continue | +-c %------------------------------------% +-c +- j = j + 1 +- if (j .gt. k+np) then +- call arscnd (t1) +- tnaitr = tnaitr + (t1 - t0) +- ido = 99 +- do 110 i = max(1,k), k+np-1 +-c +-c %--------------------------------------------% +-c | Check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine slahqr | +-c %--------------------------------------------% +-c +- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) +- if( tst1.eq.zero ) +- & tst1 = slanhs( '1', k+np, h, ldh, workd(n+1) ) +- if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 110 continue +-c +- if (msglvl .gt. 2) then +- call smout (logfil, k+np, k+np, h, ldh, ndigit, +- & '_naitr: Final upper Hessenberg matrix H of order K+NP') +- end if +-c +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Loop back to extend the factorization by another step. | +-c %--------------------------------------------------------% +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of snaitr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snapps.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snapps.f +deleted file mode 100644 +index 33b0361084..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snapps.f ++++ /dev/null +@@ -1,647 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: snapps +-c +-c\Description: +-c Given the Arnoldi factorization +-c +-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +-c +-c apply NP implicit shifts resulting in +-c +-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +-c +-c where Q is an orthogonal matrix which is the product of rotations +-c and reflections resulting from the NP bulge change sweeps. +-c The updated Arnoldi factorization becomes: +-c +-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +-c +-c\Usage: +-c call snapps +-c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, +-c WORKL, WORKD ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Problem size, i.e. size of matrix A. +-c +-c KEV Integer. (INPUT/OUTPUT) +-c KEV+NP is the size of the input matrix H. +-c KEV is the size of the updated matrix HNEW. KEV is only +-c updated on output when fewer than NP shifts are applied in +-c order to keep the conjugate pair together. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be applied. +-c +-c SHIFTR, Real array of length NP. (INPUT) +-c SHIFTI Real and imaginary part of the shifts to be applied. +-c Upon, entry to snapps, the shifts must be sorted so that the +-c conjugate pairs are in consecutive locations. +-c +-c V Real N by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, V contains the current KEV+NP Arnoldi vectors. +-c On OUTPUT, V contains the updated KEV Arnoldi vectors +-c in the first KEV columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Real (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, H contains the current KEV+NP by KEV+NP upper +-c Hessenber matrix of the Arnoldi factorization. +-c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg +-c matrix in the KEV leading submatrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RESID Real array of length N. (INPUT/OUTPUT) +-c On INPUT, RESID contains the the residual vector r_{k+p}. +-c On OUTPUT, RESID is the update residual vector rnew_{k} +-c in the first KEV locations. +-c +-c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) +-c Work array used to accumulate the rotations and reflections +-c during the bulge chase sweep. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Real work array of length (KEV+NP). (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c WORKD Real work array of length 2*N. (WORKSPACE) +-c Distributed array used in the application of the accumulated +-c orthogonal matrix Q. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c smout ARPACK utility routine that prints matrices. +-c svout ARPACK utility routine that prints vectors. +-c slabad LAPACK routine that computes machine constants. +-c slacpy LAPACK matrix copy routine. +-c slamch LAPACK routine that determines machine constants. +-c slanhs LAPACK routine that computes various norms of a matrix. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c slarf LAPACK routine that applies Householder reflection to +-c a matrix. +-c slarfg LAPACK Householder reflection construction routine. +-c slartg LAPACK Givens rotation construction routine. +-c slaset LAPACK matrix initialization routine. +-c sgemv Level 2 BLAS routine for matrix vector multiplication. +-c saxpy Level 1 BLAS that computes a vector triad. +-c scopy Level 1 BLAS that copies one vector to another . +-c sscal Level 1 BLAS that scales a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 +-c +-c\Remarks +-c 1. In this version, each shift is applied to all the sublocks of +-c the Hessenberg matrix H and not just to the submatrix that it +-c comes from. Deflation as in LAPACK routine slahqr (QR algorithm +-c for upper Hessenberg matrices ) is used. +-c The subdiagonals of H are enforced to be non-negative. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine snapps +- & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, +- & workl, workd ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer kev, ldh, ldq, ldv, n, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), +- & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr +- logical cconj, first +- Real +- & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, +- & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 +- save first, ovfl, smlnum, ulp, unfl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external saxpy, scopy, sscal, slacpy, slarfg, slarf, +- & slaset, slabad, arscnd, slartg +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slamch, slanhs, slapy2 +- external slamch, slanhs, slapy2 +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs, max, min +-c +-c %----------------% +-c | Data statements | +-c %----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------------% +-c | Set machine-dependent constants for the | +-c | stopping criterion. If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine slahqr | +-c %-----------------------------------------------% +-c +- unfl = slamch( 'safe minimum' ) +- ovfl = one / unfl +- call slabad( unfl, ovfl ) +- ulp = slamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mnapps +- kplusp = kev + np +-c +-c %--------------------------------------------% +-c | Initialize Q to the identity to accumulate | +-c | the rotations and reflections | +-c %--------------------------------------------% +-c +- call slaset ('All', kplusp, kplusp, zero, one, q, ldq) +-c +-c %----------------------------------------------% +-c | Quick return if there are no shifts to apply | +-c %----------------------------------------------% +-c +- if (np .eq. 0) go to 9000 +-c +-c %----------------------------------------------% +-c | Chase the bulge with the application of each | +-c | implicit shift. Each shift is applied to the | +-c | whole matrix including each block. | +-c %----------------------------------------------% +-c +- cconj = .false. +- do 110 jj = 1, np +- sigmar = shiftr(jj) +- sigmai = shifti(jj) +-c +- if (msglvl .gt. 2 ) then +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: shift number.') +- call svout (logfil, 1, [sigmar], ndigit, +- & '_napps: The real part of the shift ') +- call svout (logfil, 1, [sigmai], ndigit, +- & '_napps: The imaginary part of the shift ') +- end if +-c +-c %-------------------------------------------------% +-c | The following set of conditionals is necessary | +-c | in order that complex conjugate pairs of shifts | +-c | are applied together or not at all. | +-c %-------------------------------------------------% +-c +- if ( cconj ) then +-c +-c %-----------------------------------------% +-c | cconj = .true. means the previous shift | +-c | had non-zero imaginary part. | +-c %-----------------------------------------% +-c +- cconj = .false. +- go to 110 +- else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then +-c +-c %------------------------------------% +-c | Start of a complex conjugate pair. | +-c %------------------------------------% +-c +- cconj = .true. +- else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then +-c +-c %----------------------------------------------% +-c | The last shift has a nonzero imaginary part. | +-c | Don't apply it; thus the order of the | +-c | compressed H is order KEV+1 since only np-1 | +-c | were applied. | +-c %----------------------------------------------% +-c +- kev = kev + 1 +- go to 110 +- end if +- istart = 1 +- 20 continue +-c +-c %--------------------------------------------------% +-c | if sigmai = 0 then | +-c | Apply the jj-th shift ... | +-c | else | +-c | Apply the jj-th and (jj+1)-th together ... | +-c | (Note that jj < np at this point in the code) | +-c | end | +-c | to the current block of H. The next do loop | +-c | determines the current block ; | +-c %--------------------------------------------------% +-c +- do 30 i = istart, kplusp-1 +-c +-c %----------------------------------------% +-c | Check for splitting and deflation. Use | +-c | a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine slahqr | +-c %----------------------------------------% +-c +- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) +- if( tst1.eq.zero ) +- & tst1 = slanhs( '1', kplusp-jj+1, h, ldh, workl ) +- if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_napps: matrix splitting at row/column no.') +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: matrix splitting with shift number.') +- call svout (logfil, 1, h(i+1,i), ndigit, +- & '_napps: off diagonal element.') +- end if +- iend = i +- h(i+1,i) = zero +- go to 40 +- end if +- 30 continue +- iend = kplusp +- 40 continue +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [istart], ndigit, +- & '_napps: Start of current block ') +- call ivout (logfil, 1, [iend], ndigit, +- & '_napps: End of current block ') +- end if +-c +-c %------------------------------------------------% +-c | No reason to apply a shift to block of order 1 | +-c %------------------------------------------------% +-c +- if ( istart .eq. iend ) go to 100 +-c +-c %------------------------------------------------------% +-c | If istart + 1 = iend then no reason to apply a | +-c | complex conjugate pair of shifts on a 2 by 2 matrix. | +-c %------------------------------------------------------% +-c +- if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) +- & go to 100 +-c +- h11 = h(istart,istart) +- h21 = h(istart+1,istart) +- if ( abs( sigmai ) .le. zero ) then +-c +-c %---------------------------------------------% +-c | Real-valued shift ==> apply single shift QR | +-c %---------------------------------------------% +-c +- f = h11 - sigmar +- g = h21 +-c +- do 80 i = istart, iend-1 +-c +-c %-----------------------------------------------------% +-c | Construct the plane rotation G to zero out the bulge | +-c %-----------------------------------------------------% +-c +- call slartg (f, g, c, s, r) +- if (i .gt. istart) then +-c +-c %-------------------------------------------% +-c | The following ensures that h(1:iend-1,1), | +-c | the first iend-2 off diagonal of elements | +-c | H, remain non negative. | +-c %-------------------------------------------% +-c +- if (r .lt. zero) then +- r = -r +- c = -c +- s = -s +- end if +- h(i,i-1) = r +- h(i+1,i-1) = zero +- end if +-c +-c %---------------------------------------------% +-c | Apply rotation to the left of H; H <- G'*H | +-c %---------------------------------------------% +-c +- do 50 j = i, kplusp +- t = c*h(i,j) + s*h(i+1,j) +- h(i+1,j) = -s*h(i,j) + c*h(i+1,j) +- h(i,j) = t +- 50 continue +-c +-c %---------------------------------------------% +-c | Apply rotation to the right of H; H <- H*G | +-c %---------------------------------------------% +-c +- do 60 j = 1, min(i+2,iend) +- t = c*h(j,i) + s*h(j,i+1) +- h(j,i+1) = -s*h(j,i) + c*h(j,i+1) +- h(j,i) = t +- 60 continue +-c +-c %----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G | +-c %----------------------------------------------------% +-c +- do 70 j = 1, min( i+jj, kplusp ) +- t = c*q(j,i) + s*q(j,i+1) +- q(j,i+1) = - s*q(j,i) + c*q(j,i+1) +- q(j,i) = t +- 70 continue +-c +-c %---------------------------% +-c | Prepare for next rotation | +-c %---------------------------% +-c +- if (i .lt. iend-1) then +- f = h(i+1,i) +- g = h(i+2,i) +- end if +- 80 continue +-c +-c %-----------------------------------% +-c | Finished applying the real shift. | +-c %-----------------------------------% +-c +- else +-c +-c %----------------------------------------------------% +-c | Complex conjugate shifts ==> apply double shift QR | +-c %----------------------------------------------------% +-c +- h12 = h(istart,istart+1) +- h22 = h(istart+1,istart+1) +- h32 = h(istart+2,istart+1) +-c +-c %---------------------------------------------------------% +-c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | +-c %---------------------------------------------------------% +-c +- s = 2.0*sigmar +- t = slapy2 ( sigmar, sigmai ) +- u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 +- u(2) = h11 + h22 - s +- u(3) = h32 +-c +- do 90 i = istart, iend-1 +-c +- nr = min ( 3, iend-i+1 ) +-c +-c %-----------------------------------------------------% +-c | Construct Householder reflector G to zero out u(1). | +-c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | +-c %-----------------------------------------------------% +-c +- call slarfg ( nr, u(1), u(2), 1, tau ) +-c +- if (i .gt. istart) then +- h(i,i-1) = u(1) +- h(i+1,i-1) = zero +- if (i .lt. iend-1) h(i+2,i-1) = zero +- end if +- u(1) = one +-c +-c %--------------------------------------% +-c | Apply the reflector to the left of H | +-c %--------------------------------------% +-c +- call slarf ('Left', nr, kplusp-i+1, u, 1, tau, +- & h(i,i), ldh, workl) +-c +-c %---------------------------------------% +-c | Apply the reflector to the right of H | +-c %---------------------------------------% +-c +- ir = min ( i+3, iend ) +- call slarf ('Right', ir, nr, u, 1, tau, +- & h(1,i), ldh, workl) +-c +-c %-----------------------------------------------------% +-c | Accumulate the reflector in the matrix Q; Q <- Q*G | +-c %-----------------------------------------------------% +-c +- call slarf ('Right', kplusp, nr, u, 1, tau, +- & q(1,i), ldq, workl) +-c +-c %----------------------------% +-c | Prepare for next reflector | +-c %----------------------------% +-c +- if (i .lt. iend-1) then +- u(1) = h(i+1,i) +- u(2) = h(i+2,i) +- if (i .lt. iend-2) u(3) = h(i+3,i) +- end if +-c +- 90 continue +-c +-c %--------------------------------------------% +-c | Finished applying a complex pair of shifts | +-c | to the current block | +-c %--------------------------------------------% +-c +- end if +-c +- 100 continue +-c +-c %---------------------------------------------------------% +-c | Apply the same shift to the next block if there is any. | +-c %---------------------------------------------------------% +-c +- istart = iend + 1 +- if (iend .lt. kplusp) go to 20 +-c +-c %---------------------------------------------% +-c | Loop back to the top to get the next shift. | +-c %---------------------------------------------% +-c +- 110 continue +-c +-c %--------------------------------------------------% +-c | Perform a similarity transformation that makes | +-c | sure that H will have non negative sub diagonals | +-c %--------------------------------------------------% +-c +- do 120 j=1,kev +- if ( h(j+1,j) .lt. zero ) then +- call sscal( kplusp-j+1, -one, h(j+1,j), ldh ) +- call sscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) +- call sscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) +- end if +- 120 continue +-c +- do 130 i = 1, kev +-c +-c %--------------------------------------------% +-c | Final check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine slahqr | +-c %--------------------------------------------% +-c +- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) +- if( tst1.eq.zero ) +- & tst1 = slanhs( '1', kev, h, ldh, workl ) +- if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 130 continue +-c +-c %-------------------------------------------------% +-c | Compute the (kev+1)-st column of (V*Q) and | +-c | temporarily store the result in WORKD(N+1:2*N). | +-c | This is needed in the residual update since we | +-c | cannot GUARANTEE that the corresponding entry | +-c | of H would be zero as in exact arithmetic. | +-c %-------------------------------------------------% +-c +- if (h(kev+1,kev) .gt. zero) +- & call sgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, +- & workd(n+1), 1) +-c +-c %----------------------------------------------------------% +-c | Compute column 1 to kev of (V*Q) in backward order | +-c | taking advantage of the upper Hessenberg structure of Q. | +-c %----------------------------------------------------------% +-c +- do 140 i = 1, kev +- call sgemv ('N', n, kplusp-i+1, one, v, ldv, +- & q(1,kev-i+1), 1, zero, workd, 1) +- call scopy (n, workd, 1, v(1,kplusp-i+1), 1) +- 140 continue +-c +-c %-------------------------------------------------% +-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +-c %-------------------------------------------------% +-c +- call slacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) +-c +-c %--------------------------------------------------------------% +-c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | +-c %--------------------------------------------------------------% +-c +- if (h(kev+1,kev) .gt. zero) +- & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) +-c +-c %-------------------------------------% +-c | Update the residual vector: | +-c | r <- sigmak*r + betak*v(:,kev+1) | +-c | where | +-c | sigmak = (e_{kplusp}'*Q)*e_{kev} | +-c | betak = e_{kev+1}'*H*e_{kev} | +-c %-------------------------------------% +-c +- call sscal (n, q(kplusp,kev), resid, 1) +- if (h(kev+1,kev) .gt. zero) +- & call saxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) +-c +- if (msglvl .gt. 1) then +- call svout (logfil, 1, q(kplusp,kev), ndigit, +- & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') +- call svout (logfil, 1, h(kev+1,kev), ndigit, +- & '_napps: betak = e_{kev+1}^T*H*e_{kev}') +- call ivout (logfil, 1, [kev], ndigit, +- & '_napps: Order of the final Hessenberg matrix ') +- if (msglvl .gt. 2) then +- call smout (logfil, kev, kev, h, ldh, ndigit, +- & '_napps: updated Hessenberg matrix H for next iteration') +- end if +-c +- end if +-c +- 9000 continue +- call arscnd (t1) +- tnapps = tnapps + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of snapps | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaup2.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaup2.f +deleted file mode 100644 +index e3be754eac..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaup2.f ++++ /dev/null +@@ -1,847 +0,0 @@ +-c\BeginDoc +-c +-c\Name: snaup2 +-c +-c\Description: +-c Intermediate level interface called by snaupd. +-c +-c\Usage: +-c call snaup2 +-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +-c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, +-c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c +-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in snaupd. +-c MODE, ISHIFT, MXITER: see the definition of IPARAM in snaupd. +-c +-c NP Integer. (INPUT/OUTPUT) +-c Contains the number of implicit shifts to apply during +-c each Arnoldi iteration. +-c If ISHIFT=1, NP is adjusted dynamically at each iteration +-c to accelerate convergence and prevent stagnation. +-c This is also roughly equal to the number of matrix-vector +-c products (involving the operator OP) per Arnoldi iteration. +-c The logic for adjusting is contained within the current +-c subroutine. +-c If ISHIFT=0, NP is the number of shifts the user needs +-c to provide via reverse communication. 0 < NP < NCV-NEV. +-c NP may be less than NCV-NEV for two reasons. The first, is +-c to keep complex conjugate pairs of "wanted" Ritz values +-c together. The second, is that a leading block of the current +-c upper Hessenberg matrix has split off and contains "unwanted" +-c Ritz values. +-c Upon termination of the IRA iteration, NP contains the number +-c of "converged" wanted Ritz values. +-c +-c IUPD Integer. (INPUT) +-c IUPD .EQ. 0: use explicit restart instead implicit update. +-c IUPD .NE. 0: use implicit update. +-c +-c V Real N by (NEV+NP) array. (INPUT/OUTPUT) +-c The Arnoldi basis vectors are returned in the first NEV +-c columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Real (NEV+NP) by (NEV+NP) array. (OUTPUT) +-c H is used to store the generated upper Hessenberg matrix +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZR, Real arrays of length NEV+NP. (OUTPUT) +-c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. +-c imaginary) part of the computed Ritz values of OP. +-c +-c BOUNDS Real array of length NEV+NP. (OUTPUT) +-c BOUNDS(1:NEV) contain the error bounds corresponding to +-c the computed Ritz values. +-c +-c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) +-c Private (replicated) work array used to accumulate the +-c rotation in the shift application step. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Real work array of length at least +-c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. It is used in shifts calculation, shifts +-c application and convergence checking. +-c +-c On exit, the last 3*(NEV+NP) locations of WORKL contain +-c the Ritz values (real,imaginary) and associated Ritz +-c estimates of the current Hessenberg matrix. They are +-c listed in the same order as returned from sneigh. +-c +-c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations +-c of WORKL are used in reverse communication to hold the user +-c supplied shifts. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Real work array of length 3*N. (WORKSPACE) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note in DNAUPD. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal return. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. +-c NP returns the number of converged Ritz values. +-c = 2: No shifts could be applied. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c This should never happen. +-c = -9: Starting vector is zero. +-c = -9999: Could not build an Arnoldi factorization. +-c Size that was built in returned in NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c sgetv0 ARPACK initial vector generation routine. +-c snaitr ARPACK Arnoldi factorization routine. +-c snapps ARPACK application of implicit shifts routine. +-c snconv ARPACK convergence of Ritz values routine. +-c sneigh ARPACK compute Ritz values and error bounds routine. +-c sngets ARPACK reorder Ritz values and error bounds routine. +-c ssortc ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c smout ARPACK utility routine that prints matrices +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c scopy Level 1 BLAS that copies one vector to another . +-c sdot Level 1 BLAS that computes the scalar product of two vectors. +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c sswap Level 1 BLAS that swaps two vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 +-c +-c\Remarks +-c 1. None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine snaup2 +- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, +- & q, ldq, workl, ipntr, workd, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, +- & n, nev, np +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(13) +- Real +- & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), +- & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), +- & workd(3*n), workl( (nev+np)*(nev+np+3) ) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0 , zero = 0.0E+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character wprime*2 +- logical cnorm , getv0, initv, update, ushift +- integer ierr , iter , j , kplusp, msglvl, nconv, +- & nevbef, nev0 , np0 , nptemp, numcnv +- Real +- & rnorm , temp , eps23 +- save cnorm , getv0, initv, update, ushift, +- & rnorm , iter , eps23, kplusp, msglvl, nconv , +- & nevbef, nev0 , np0 , numcnv +-c +-c %-----------------------% +-c | Local array arguments | +-c %-----------------------% +-c +- integer kp(4) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy , sgetv0, snaitr, snconv, sneigh, +- & sngets, snapps, svout , ivout , arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & sdot, snrm2, slapy2, slamch +- external sdot, snrm2, slapy2, slamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic min, max, abs, sqrt +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +- call arscnd (t0) +-c +- msglvl = mnaup2 +-c +-c %-------------------------------------% +-c | Get the machine dependent constant. | +-c %-------------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0 ) +-c +- nev0 = nev +- np0 = np +-c +-c %-------------------------------------% +-c | kplusp is the bound on the largest | +-c | Lanczos factorization built. | +-c | nconv is the current number of | +-c | "converged" eigenvlues. | +-c | iter is the counter on the current | +-c | iteration step. | +-c %-------------------------------------% +-c +- kplusp = nev + np +- nconv = 0 +- iter = 0 +-c +-c %---------------------------------------% +-c | Set flags for computing the first NEV | +-c | steps of the Arnoldi factorization. | +-c %---------------------------------------% +-c +- getv0 = .true. +- update = .false. +- ushift = .false. +- cnorm = .false. +-c +- if (info .ne. 0) then +-c +-c %--------------------------------------------% +-c | User provides the initial residual vector. | +-c %--------------------------------------------% +-c +- initv = .true. +- info = 0 +- else +- initv = .false. +- end if +- end if +-c +-c %---------------------------------------------% +-c | Get a possibly random starting vector and | +-c | force it into the range of the operator OP. | +-c %---------------------------------------------% +-c +- 10 continue +-c +- if (getv0) then +- call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, +- & ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (rnorm .eq. zero) then +-c +-c %-----------------------------------------% +-c | The initial vector is zero. Error exit. | +-c %-----------------------------------------% +-c +- info = -9 +- go to 1100 +- end if +- getv0 = .false. +- ido = 0 +- end if +-c +-c %-----------------------------------% +-c | Back from reverse communication : | +-c | continue with update step | +-c %-----------------------------------% +-c +- if (update) go to 20 +-c +-c %-------------------------------------------% +-c | Back from computing user specified shifts | +-c %-------------------------------------------% +-c +- if (ushift) go to 50 +-c +-c %-------------------------------------% +-c | Back from computing residual norm | +-c | at the end of the current iteration | +-c %-------------------------------------% +-c +- if (cnorm) go to 100 +-c +-c %----------------------------------------------------------% +-c | Compute the first NEV steps of the Arnoldi factorization | +-c %----------------------------------------------------------% +-c +- call snaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, +- & h, ldh, ipntr, workd, info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +-c +-c %--------------------------------------------------------------% +-c | | +-c | M A I N ARNOLDI I T E R A T I O N L O O P | +-c | Each iteration implicitly restarts the Arnoldi | +-c | factorization in place. | +-c | | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- iter = iter + 1 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [iter], ndigit, +- & '_naup2: **** Start of major iteration number ****') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c | Adjust NP since NEV might have been updated by last call | +-c | to the shift application routine snapps. | +-c %-----------------------------------------------------------% +-c +- np = kplusp - nev +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [nev], ndigit, +- & '_naup2: The length of the current Arnoldi factorization') +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: Extend the Arnoldi factorization by') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c %-----------------------------------------------------------% +-c +- ido = 0 +- 20 continue +- update = .true. +-c +- call snaitr (ido , bmat, n , nev, np , mode , resid, +- & rnorm, v , ldv, h , ldh, ipntr, workd, +- & info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +- update = .false. +-c +- if (msglvl .gt. 1) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_naup2: Corresponding B-norm of the residual') +- end if +-c +-c %--------------------------------------------------------% +-c | Compute the eigenvalues and corresponding error bounds | +-c | of the current upper Hessenberg matrix. | +-c %--------------------------------------------------------% +-c +- call sneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, +- & q, ldq, workl, ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 1200 +- end if +-c +-c %----------------------------------------------------% +-c | Make a copy of eigenvalues and corresponding error | +-c | bounds obtained from sneigh. | +-c %----------------------------------------------------% +-c +- call scopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) +- call scopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) +- call scopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The wanted part of the spectrum and corresponding | +-c | error bounds are in the last NEV loc. of RITZR, | +-c | RITZI and BOUNDS respectively. The variables NEV | +-c | and NP may be updated if the NEV-th wanted Ritz | +-c | value has a non zero imaginary part. In this case | +-c | NEV is increased by one and NP decreased by one. | +-c | NOTE: The last two arguments of sngets are no | +-c | longer used as of version 2.1. | +-c %---------------------------------------------------% +-c +- nev = nev0 +- np = np0 +- numcnv = nev +- call sngets (ishift, which, nev, np, ritzr, ritzi, +- & bounds, workl, workl(np+1)) +- if (nev .eq. nev0+1) numcnv = nev0+1 +-c +-c %-------------------% +-c | Convergence test. | +-c %-------------------% +-c +- call scopy (nev, bounds(np+1), 1, workl(2*np+1), 1) +- call snconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), +- & tol, nconv) +-c +- if (msglvl .gt. 2) then +- kp(1) = nev +- kp(2) = np +- kp(3) = numcnv +- kp(4) = nconv +- call ivout (logfil, 4, kp, ndigit, +- & '_naup2: NEV, NP, NUMCNV, NCONV are') +- call svout (logfil, kplusp, ritzr, ndigit, +- & '_naup2: Real part of the eigenvalues of H') +- call svout (logfil, kplusp, ritzi, ndigit, +- & '_naup2: Imaginary part of the eigenvalues of H') +- call svout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Ritz estimates of the current NCV Ritz values') +- end if +-c +-c %---------------------------------------------------------% +-c | Count the number of unwanted Ritz values that have zero | +-c | Ritz estimates. If any Ritz estimates are equal to zero | +-c | then a leading block of H of order equal to at least | +-c | the number of Ritz values with zero Ritz estimates has | +-c | split off. None of these Ritz values may be removed by | +-c | shifting. Decrease NP the number of shifts to apply. If | +-c | no shifts may be applied, then prepare to exit | +-c %---------------------------------------------------------% +-c +- nptemp = np +- do 30 j=1, nptemp +- if (bounds(j) .eq. zero) then +- np = np - 1 +- nev = nev + 1 +- end if +- 30 continue +-c +- if ( (nconv .ge. numcnv) .or. +- & (iter .gt. mxiter) .or. +- & (np .eq. 0) ) then +-c +- if (msglvl .gt. 4) then +- call svout(logfil, kplusp, workl(kplusp**2+1), ndigit, +- & '_naup2: Real part of the eig computed by _neigh:') +- call svout(logfil, kplusp, workl(kplusp**2+kplusp+1), +- & ndigit, +- & '_naup2: Imag part of the eig computed by _neigh:') +- call svout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), +- & ndigit, +- & '_naup2: Ritz eistmates computed by _neigh:') +- end if +-c +-c %------------------------------------------------% +-c | Prepare to exit. Put the converged Ritz values | +-c | and corresponding bounds in RITZ(1:NCONV) and | +-c | BOUNDS(1:NCONV) respectively. Then sort. Be | +-c | careful when NCONV > NP | +-c %------------------------------------------------% +-c +-c %------------------------------------------% +-c | Use h( 3,1 ) as storage to communicate | +-c | rnorm to _neupd if needed | +-c %------------------------------------------% +- +- h(3,1) = rnorm +-c +-c %----------------------------------------------% +-c | To be consistent with sngets, we first do a | +-c | pre-processing sort in order to keep complex | +-c | conjugate pairs together. This is similar | +-c | to the pre-processing sort used in sngets | +-c | except that the sort is done in the opposite | +-c | order. | +-c %----------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SR' +- if (which .eq. 'SM') wprime = 'LR' +- if (which .eq. 'LR') wprime = 'SM' +- if (which .eq. 'SR') wprime = 'LM' +- if (which .eq. 'LI') wprime = 'SM' +- if (which .eq. 'SI') wprime = 'LM' +-c +- call ssortc (wprime, .true., kplusp, ritzr, ritzi, bounds) +-c +-c %----------------------------------------------% +-c | Now sort Ritz values so that converged Ritz | +-c | values appear within the first NEV locations | +-c | of ritzr, ritzi and bounds, and the most | +-c | desired one appears at the front. | +-c %----------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SM' +- if (which .eq. 'SM') wprime = 'LM' +- if (which .eq. 'LR') wprime = 'SR' +- if (which .eq. 'SR') wprime = 'LR' +- if (which .eq. 'LI') wprime = 'SI' +- if (which .eq. 'SI') wprime = 'LI' +-c +- call ssortc(wprime, .true., kplusp, ritzr, ritzi, bounds) +-c +-c %--------------------------------------------------% +-c | Scale the Ritz estimate of each Ritz value | +-c | by 1 / max(eps23,magnitude of the Ritz value). | +-c %--------------------------------------------------% +-c +- do 35 j = 1, numcnv +- temp = max(eps23,slapy2(ritzr(j), +- & ritzi(j))) +- bounds(j) = bounds(j)/temp +- 35 continue +-c +-c %----------------------------------------------------% +-c | Sort the Ritz values according to the scaled Ritz | +-c | estimates. This will push all the converged ones | +-c | towards the front of ritzr, ritzi, bounds | +-c | (in the case when NCONV < NEV.) | +-c %----------------------------------------------------% +-c +- wprime = 'LR' +- call ssortc(wprime, .true., numcnv, bounds, ritzr, ritzi) +-c +-c %----------------------------------------------% +-c | Scale the Ritz estimate back to its original | +-c | value. | +-c %----------------------------------------------% +-c +- do 40 j = 1, numcnv +- temp = max(eps23, slapy2(ritzr(j), +- & ritzi(j))) +- bounds(j) = bounds(j)*temp +- 40 continue +-c +-c %------------------------------------------------% +-c | Sort the converged Ritz values again so that | +-c | the "threshold" value appears at the front of | +-c | ritzr, ritzi and bound. | +-c %------------------------------------------------% +-c +- call ssortc(which, .true., nconv, ritzr, ritzi, bounds) +-c +- if (msglvl .gt. 1) then +- call svout (logfil, kplusp, ritzr, ndigit, +- & '_naup2: Sorted real part of the eigenvalues') +- call svout (logfil, kplusp, ritzi, ndigit, +- & '_naup2: Sorted imaginary part of the eigenvalues') +- call svout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Sorted ritz estimates.') +- end if +-c +-c %------------------------------------% +-c | Max iterations have been exceeded. | +-c %------------------------------------% +-c +- if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 +-c +-c %---------------------% +-c | No shifts to apply. | +-c %---------------------% +-c +- if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 +-c +- np = nconv +- go to 1100 +-c +- else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then +-c +-c %-------------------------------------------------% +-c | Do not have all the requested eigenvalues yet. | +-c | To prevent possible stagnation, adjust the size | +-c | of NEV. | +-c %-------------------------------------------------% +-c +- nevbef = nev +- nev = nev + min(nconv, np/2) +- if (nev .eq. 1 .and. kplusp .ge. 6) then +- nev = kplusp / 2 +- else if (nev .eq. 1 .and. kplusp .gt. 3) then +- nev = 2 +- end if +-c %---- Scipy fix ------------------------------------------------ +-c | We must keep nev below this value, as otherwise we can get +-c | np == 0 (note that sngets below can bump nev by 1). If np == 0, +-c | the next call to `snaitr` will write out-of-bounds. +-c | +- if (nev .gt. kplusp - 2) then +- nev = kplusp - 2 +- end if +-c | +-c %---- Scipy fix end -------------------------------------------- +- +-c +- np = kplusp - nev +-c +-c %---------------------------------------% +-c | If the size of NEV was just increased | +-c | resort the eigenvalues. | +-c %---------------------------------------% +-c +- if (nevbef .lt. nev) +- & call sngets (ishift, which, nev, np, ritzr, ritzi, +- & bounds, workl, workl(np+1)) +-c +- end if +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [nconv], ndigit, +- & '_naup2: no. of "converged" Ritz values at this iter.') +- if (msglvl .gt. 1) then +- kp(1) = nev +- kp(2) = np +- call ivout (logfil, 2, kp, ndigit, +- & '_naup2: NEV and NP are') +- call svout (logfil, nev, ritzr(np+1), ndigit, +- & '_naup2: "wanted" Ritz values -- real part') +- call svout (logfil, nev, ritzi(np+1), ndigit, +- & '_naup2: "wanted" Ritz values -- imag part') +- call svout (logfil, nev, bounds(np+1), ndigit, +- & '_naup2: Ritz estimates of the "wanted" values ') +- end if +- end if +-c +- if (ishift .eq. 0) then +-c +-c %-------------------------------------------------------% +-c | User specified shifts: reverse communication to | +-c | compute the shifts. They are returned in the first | +-c | 2*NP locations of WORKL. | +-c %-------------------------------------------------------% +-c +- ushift = .true. +- ido = 3 +- go to 9000 +- end if +-c +- 50 continue +-c +-c %------------------------------------% +-c | Back from reverse communication; | +-c | User specified shifts are returned | +-c | in WORKL(1:2*NP) | +-c %------------------------------------% +-c +- ushift = .false. +-c +- if ( ishift .eq. 0 ) then +-c +-c %----------------------------------% +-c | Move the NP shifts from WORKL to | +-c | RITZR, RITZI to free up WORKL | +-c | for non-exact shift case. | +-c %----------------------------------% +-c +- call scopy (np, workl, 1, ritzr, 1) +- call scopy (np, workl(np+1), 1, ritzi, 1) +- end if +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: The number of shifts to apply ') +- call svout (logfil, np, ritzr, ndigit, +- & '_naup2: Real part of the shifts') +- call svout (logfil, np, ritzi, ndigit, +- & '_naup2: Imaginary part of the shifts') +- if ( ishift .eq. 1 ) +- & call svout (logfil, np, bounds, ndigit, +- & '_naup2: Ritz estimates of the shifts') +- end if +-c +-c %---------------------------------------------------------% +-c | Apply the NP implicit shifts by QR bulge chasing. | +-c | Each shift is applied to the whole upper Hessenberg | +-c | matrix H. | +-c | The first 2*N locations of WORKD are used as workspace. | +-c %---------------------------------------------------------% +-c +- call snapps (n, nev, np, ritzr, ritzi, v, ldv, +- & h, ldh, resid, q, ldq, workl, workd) +-c +-c %---------------------------------------------% +-c | Compute the B-norm of the updated residual. | +-c | Keep B*RESID in WORKD(1:N) to be used in | +-c | the first step of the next call to snaitr. | +-c %---------------------------------------------% +-c +- cnorm = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*RESID | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd, 1) +- end if +-c +- 100 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(1:N) := B*RESID | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- rnorm = sdot (n, resid, 1, workd, 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = snrm2(n, resid, 1) +- end if +- cnorm = .false. +-c +- if (msglvl .gt. 2) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_naup2: B-norm of residual for compressed factorization') +- call smout (logfil, nev, nev, h, ldh, ndigit, +- & '_naup2: Compressed upper Hessenberg matrix H') +- end if +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 1100 continue +-c +- mxiter = iter +- nev = numcnv +-c +- 1200 continue +- ido = 99 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- call arscnd (t1) +- tnaup2 = t1 - t0 +-c +- 9000 continue +-c +-c %---------------% +-c | End of snaup2 | +-c %---------------% +-c +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaupd.f +deleted file mode 100644 +index d6fad33863..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snaupd.f ++++ /dev/null +@@ -1,693 +0,0 @@ +-c\BeginDoc +-c +-c\Name: snaupd +-c +-c\Description: +-c Reverse communication interface for the Implicitly Restarted Arnoldi +-c iteration. This subroutine computes approximations to a few eigenpairs +-c of a linear operator "OP" with respect to a semi-inner product defined by +-c a symmetric positive semi-definite real matrix B. B may be the identity +-c matrix. NOTE: If the linear operator "OP" is real and symmetric +-c with respect to the real positive semi-definite symmetric matrix B, +-c i.e. B*OP = (OP`)*B, then subroutine ssaupd should be used instead. +-c +-c The computed approximate eigenvalues are called Ritz values and +-c the corresponding approximate eigenvectors are called Ritz vectors. +-c +-c snaupd is usually called iteratively to solve one of the +-c following problems: +-c +-c Mode 1: A*x = lambda*x. +-c ===> OP = A and B = I. +-c +-c Mode 2: A*x = lambda*M*x, M symmetric positive definite +-c ===> OP = inv[M]*A and B = M. +-c ===> (If M can be factored see remark 3 below) +-c +-c Mode 3: A*x = lambda*M*x, M symmetric semi-definite +-c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. +-c ===> shift-and-invert mode (in real arithmetic) +-c If OP*x = amu*x, then +-c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. +-c Note: If sigma is real, i.e. imaginary part of sigma is zero; +-c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M +-c amu == 1/(lambda-sigma). +-c +-c Mode 4: A*x = lambda*M*x, M symmetric semi-definite +-c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. +-c ===> shift-and-invert mode (in real arithmetic) +-c If OP*x = amu*x, then +-c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. +-c +-c Both mode 3 and 4 give the same enhancement to eigenvalues close to +-c the (complex) shift sigma. However, as lambda goes to infinity, +-c the operator OP in mode 4 dampens the eigenvalues more strongly than +-c does OP defined in mode 3. +-c +-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +-c should be accomplished either by a direct method +-c using a sparse matrix factorization and solving +-c +-c [A - sigma*M]*w = v or M*w = v, +-c +-c or through an iterative method for solving these +-c systems. If an iterative method is used, the +-c convergence test must be more stringent than +-c the accuracy requirements for the eigenvalue +-c approximations. +-c +-c\Usage: +-c call snaupd +-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +-c IPNTR, WORKD, WORKL, LWORKL, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to snaupd. IDO will be set internally to +-c indicate the type of operation to be performed. Control is +-c then given back to the calling routine which has the +-c responsibility to carry out the requested operation and call +-c snaupd with the result. The operand is given in +-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c In mode 3 and 4, the vector B * X is already +-c available in WORKD(ipntr(3)). It does not +-c need to be recomputed in forming OP * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 3: compute the IPARAM(8) real and imaginary parts +-c of the shifts where INPTR(14) is the pointer +-c into WORKL for placing the shifts. See Remark +-c 5 below. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. +-c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x +-c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c WHICH Character*2. (INPUT) +-c 'LM' -> want the NEV eigenvalues of largest magnitude. +-c 'SM' -> want the NEV eigenvalues of smallest magnitude. +-c 'LR' -> want the NEV eigenvalues of largest real part. +-c 'SR' -> want the NEV eigenvalues of smallest real part. +-c 'LI' -> want the NEV eigenvalues of largest imaginary part. +-c 'SI' -> want the NEV eigenvalues of smallest imaginary part. +-c +-c NEV Integer. (INPUT) +-c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. +-c +-c TOL Real scalar. (INPUT) +-c Stopping criterion: the relative accuracy of the Ritz value +-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) +-c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. +-c DEFAULT = SLAMCH('EPS') (machine precision as computed +-c by the LAPACK auxiliary subroutine SLAMCH). +-c +-c RESID Real array of length N. (INPUT/OUTPUT) +-c On INPUT: +-c If INFO .EQ. 0, a random initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c On OUTPUT: +-c RESID contains the final residual vector. +-c +-c NCV Integer. (INPUT) +-c Number of columns of the matrix V. NCV must satisfy the two +-c inequalities 2 <= NCV-NEV and NCV <= N. +-c This will indicate how many Arnoldi vectors are generated +-c at each iteration. After the startup phase in which NEV +-c Arnoldi vectors are generated, the algorithm generates +-c approximately NCV-NEV Arnoldi vectors at each subsequent update +-c iteration. Most of the cost in generating each Arnoldi vector is +-c in the matrix-vector operation OP*x. +-c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz +-c values are kept together. (See remark 4 below) +-c +-c V Real array N by NCV. (OUTPUT) +-c Contains the final set of Arnoldi basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling program. +-c +-c IPARAM Integer array of length 11. (INPUT/OUTPUT) +-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +-c The shifts selected at each iteration are used to restart +-c the Arnoldi iteration in an implicit fashion. +-c ------------------------------------------------------------- +-c ISHIFT = 0: the shifts are provided by the user via +-c reverse communication. The real and imaginary +-c parts of the NCV eigenvalues of the Hessenberg +-c matrix H are returned in the part of the WORKL +-c array corresponding to RITZR and RITZI. See remark +-c 5 below. +-c ISHIFT = 1: exact shifts with respect to the current +-c Hessenberg matrix H. This is equivalent to +-c restarting the iteration with a starting vector +-c that is a linear combination of approximate Schur +-c vectors associated with the "wanted" Ritz values. +-c ------------------------------------------------------------- +-c +-c IPARAM(2) = No longer referenced. +-c +-c IPARAM(3) = MXITER +-c On INPUT: maximum number of Arnoldi update iterations allowed. +-c On OUTPUT: actual number of Arnoldi update iterations taken. +-c +-c IPARAM(4) = NB: blocksize to be used in the recurrence. +-c The code currently works only for NB = 1. +-c +-c IPARAM(5) = NCONV: number of "converged" Ritz values. +-c This represents the number of Ritz values that satisfy +-c the convergence criterion. +-c +-c IPARAM(6) = IUPD +-c No longer referenced. Implicit restarting is ALWAYS used. +-c +-c IPARAM(7) = MODE +-c On INPUT determines what type of eigenproblem is being solved. +-c Must be 1,2,3,4; See under \Description of snaupd for the +-c four modes available. +-c +-c IPARAM(8) = NP +-c When ido = 3 and the user provides shifts through reverse +-c communication (IPARAM(1)=0), snaupd returns NP, the number +-c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark +-c 5 below. +-c +-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +-c OUTPUT: NUMOP = total number of OP*x operations, +-c NUMOPB = total number of B*x operations if BMAT='G', +-c NUMREO = total number of steps of re-orthogonalization. +-c +-c IPNTR Integer array of length 14. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD and WORKL +-c arrays for matrices/vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X in WORKD. +-c IPNTR(2): pointer to the current result vector Y in WORKD. +-c IPNTR(3): pointer to the vector B * X in WORKD when used in +-c the shift-and-invert mode. +-c IPNTR(4): pointer to the next available location in WORKL +-c that is untouched by the program. +-c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix +-c H in WORKL. +-c IPNTR(6): pointer to the real part of the ritz value array +-c RITZR in WORKL. +-c IPNTR(7): pointer to the imaginary part of the ritz value array +-c RITZI in WORKL. +-c IPNTR(8): pointer to the Ritz estimates in array WORKL associated +-c with the Ritz values located in RITZR and RITZI in WORKL. +-c +-c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. +-c +-c Note: IPNTR(9:13) is only referenced by sneupd. See Remark 2 below. +-c +-c IPNTR(9): pointer to the real part of the NCV RITZ values of the +-c original system. +-c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of +-c the original system. +-c IPNTR(11): pointer to the NCV corresponding error bounds. +-c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c sneupd if RVEC = .TRUE. See Remark 2 below. +-c ------------------------------------------------------------- +-c +-c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration. Upon termination +-c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace +-c associated with the converged Ritz values is desired, see remark +-c 2 below, subroutine sneupd uses this output. +-c See Data Distribution Note below. +-c +-c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. See Data Distribution Note below. +-c +-c LWORKL Integer. (INPUT) +-c LWORKL must be at least 3*NCV**2 + 6*NCV. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal exit. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. IPARAM(5) +-c returns the number of wanted converged Ritz values. +-c = 2: No longer an informational error. Deprecated starting +-c with release 2 of ARPACK. +-c = 3: No shifts could be applied during a cycle of the +-c Implicitly restarted Arnoldi iteration. One possibility +-c is to increase the size of NCV relative to NEV. +-c See remark 4 below. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -4: The maximum number of Arnoldi update iteration +-c must be greater than zero. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work array is not sufficient. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3,4. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: IPARAM(1) must be equal to 0 or 1. +-c = -9999: Could not build an Arnoldi factorization. +-c IPARAM(5) returns the size of the current Arnoldi +-c factorization. +-c +-c\Remarks +-c 1. The computed Ritz values are approximate eigenvalues of OP. The +-c selection of WHICH should be made with this in mind when +-c Mode = 3 and 4. After convergence, approximate eigenvalues of the +-c original problem may be obtained with the ARPACK subroutine sneupd. +-c +-c 2. If a basis for the invariant subspace corresponding to the converged Ritz +-c values is needed, the user must call sneupd immediately following +-c completion of snaupd. This is new starting with release 2 of ARPACK. +-c +-c 3. If M can be factored into a Cholesky factorization M = LL` +-c then Mode = 2 should not be selected. Instead one should use +-c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +-c linear systems should be solved with L and L` rather +-c than computing inverses. After convergence, an approximate +-c eigenvector z of the original problem is recovered by solving +-c L`z = x where x is a Ritz vector of OP. +-c +-c 4. At present there is no a-priori analysis to guide the selection +-c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 2. +-c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of +-c the same type are to be solved, one should experiment with increasing +-c NCV while keeping NEV fixed for a given test problem. This will +-c usually decrease the required number of OP*x operations but it +-c also increases the work and storage required to maintain the orthogonal +-c basis vectors. The optimal "cross-over" with respect to CPU time +-c is problem dependent and must be determined empirically. +-c See Chapter 8 of Reference 2 for further information. +-c +-c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +-c NP = IPARAM(8) real and imaginary parts of the shifts in locations +-c real part imaginary part +-c ----------------------- -------------- +-c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) +-c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) +-c . . +-c . . +-c . . +-c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). +-c +-c Only complex conjugate pairs of shifts may be applied and the pairs +-c must be placed in consecutive locations. The real part of the +-c eigenvalues of the current upper Hessenberg matrix are located in +-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part +-c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered +-c according to the order defined by WHICH. The complex conjugate +-c pairs are kept together and the associated Ritz estimates are located in +-c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). +-c +-c----------------------------------------------------------------------- +-c +-c\Data Distribution Note: +-c +-c Fortran-D syntax: +-c ================ +-c Real resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c decompose d1(n), d2(n,ncv) +-c align resid(i) with d1(i) +-c align v(i,j) with d2(i,j) +-c align workd(i) with d1(i) range (1:n) +-c align workd(i) with d1(i-n) range (n+1:2*n) +-c align workd(i) with d1(i-2*n) range (2*n+1:3*n) +-c distribute d1(block), d2(block,:) +-c replicated workl(lworkl) +-c +-c Cray MPP syntax: +-c =============== +-c Real resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) +-c shared resid(block), v(block,:), workd(block,:) +-c replicated workl(lworkl) +-c +-c CM2/CM5 syntax: +-c ============== +-c +-c----------------------------------------------------------------------- +-c +-c include 'ex-nonsym.doc' +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for +-c Real Matrices", Linear Algebra and its Applications, vol 88/89, +-c pp 575-595, (1987). +-c +-c\Routines called: +-c snaup2 ARPACK routine that implements the Implicitly Restarted +-c Arnoldi Iteration. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/16/93: Version '1.1' +-c +-c\SCCS Information: @(#) +-c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\Remarks +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine snaupd +- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, +- & ipntr, workd, workl, lworkl, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ldv, lworkl, n, ncv, nev +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- Real +- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0 , zero = 0.0E+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, levec, mode, msglvl, mxiter, nb, +- & nev0, next, np, ritzi, ritzr, j +- save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, +- & levec, mode, msglvl, mxiter, nb, nev0, next, +- & np, ritzi, ritzr +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external snaup2, svout, ivout, arscnd, sstatn +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slamch +- external slamch +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call sstatn +- call arscnd (t0) +- msglvl = mnaupd +-c +-c %----------------% +-c | Error checking | +-c %----------------% +-c +- ierr = 0 +- ishift = iparam(1) +-c levec = iparam(2) +- mxiter = iparam(3) +-c nb = iparam(4) +- nb = 1 +-c +-c %--------------------------------------------% +-c | Revision 2 performs only implicit restart. | +-c %--------------------------------------------% +-c +- iupd = 1 +- mode = iparam(7) +-c +- if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev+1 .or. ncv .gt. n) then +- ierr = -3 +- else if (mxiter .le. 0) then +- ierr = -4 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 6*ncv) then +- ierr = -7 +- else if (mode .lt. 1 .or. mode .gt. 4) then +- ierr = -10 +- else if (mode .eq. 1 .and. bmat .eq. 'G') then +- ierr = -11 +- else if (ishift .lt. 0 .or. ishift .gt. 1) then +- ierr = -12 +- end if +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- ido = 99 +- go to 9000 +- end if +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- if (nb .le. 0) nb = 1 +- if (tol .le. zero) tol = slamch('EpsMach') +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c | NEV0 is the local variable designating the | +-c | size of the invariant subspace desired. | +-c %----------------------------------------------% +-c +- np = ncv - nev +- nev0 = nev +-c +-c %-----------------------------% +-c | Zero out internal workspace | +-c %-----------------------------% +-c +- do 10 j = 1, 3*ncv**2 + 6*ncv +- workl(j) = zero +- 10 continue +-c +-c %-------------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | +-c | parts of ritz values | +-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | +-c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | +-c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | +-c | The final workspace is needed by subroutine sneigh called | +-c | by snaup2. Subroutine sneigh calls LAPACK routines for | +-c | calculating eigenvalues and the last row of the eigenvector | +-c | matrix. | +-c %-------------------------------------------------------------% +-c +- ldh = ncv +- ldq = ncv +- ih = 1 +- ritzr = ih + ldh*ncv +- ritzi = ritzr + ncv +- bounds = ritzi + ncv +- iq = bounds + ncv +- iw = iq + ldq*ncv +- next = iw + ncv**2 + 3*ncv +-c +- ipntr(4) = next +- ipntr(5) = ih +- ipntr(6) = ritzr +- ipntr(7) = ritzi +- ipntr(8) = bounds +- ipntr(14) = iw +-c +- end if +-c +-c %-------------------------------------------------------% +-c | Carry out the Implicitly restarted Arnoldi Iteration. | +-c %-------------------------------------------------------% +-c +- call snaup2 +- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), +- & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), +- & ipntr, workd, info ) +-c +-c %--------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP or shifts. | +-c %--------------------------------------------------% +-c +- if (ido .eq. 3) iparam(8) = np +- if (ido .ne. 99) go to 9000 +-c +- iparam(3) = mxiter +- iparam(5) = np +- iparam(9) = nopx +- iparam(10) = nbx +- iparam(11) = nrorth +-c +-c %------------------------------------% +-c | Exit if there was an informational | +-c | error within snaup2. | +-c %------------------------------------% +-c +- if (info .lt. 0) go to 9000 +- if (info .eq. 2) info = 3 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [mxiter], ndigit, +- & '_naupd: Number of update iterations taken') +- call ivout (logfil, 1, [np], ndigit, +- & '_naupd: Number of wanted "converged" Ritz values') +- call svout (logfil, np, workl(ritzr), ndigit, +- & '_naupd: Real part of the final Ritz values') +- call svout (logfil, np, workl(ritzi), ndigit, +- & '_naupd: Imaginary part of the final Ritz values') +- call svout (logfil, np, workl(bounds), ndigit, +- & '_naupd: Associated Ritz estimates') +- end if +-c +- call arscnd (t1) +- tnaupd = t1 - t0 +-c +- if (msglvl .gt. 0) then +-c +-c %--------------------------------------------------------% +-c | Version Number & Version Date are defined in version.h | +-c %--------------------------------------------------------% +-c +- write (6,1000) +- write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, +- & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, +- & tgetv0, tneigh, tngets, tnapps, tnconv, trvec +- 1000 format (//, +- & 5x, '=============================================',/ +- & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ +- & 5x, '= Version Number: ', ' 2.4' , 21x, ' =',/ +- & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ +- & 5x, '=============================================',/ +- & 5x, '= Summary of timing statistics =',/ +- & 5x, '=============================================',//) +- 1100 format ( +- & 5x, 'Total number update iterations = ', i5,/ +- & 5x, 'Total number of OP*x operations = ', i5,/ +- & 5x, 'Total number of B*x operations = ', i5,/ +- & 5x, 'Total number of reorthogonalization steps = ', i5,/ +- & 5x, 'Total number of iterative refinement steps = ', i5,/ +- & 5x, 'Total number of restart steps = ', i5,/ +- & 5x, 'Total time in user OP*x operation = ', f12.6,/ +- & 5x, 'Total time in user B*x operation = ', f12.6,/ +- & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ +- & 5x, 'Total time in naup2 routine = ', f12.6,/ +- & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ +- & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ +- & 5x, 'Total time in (re)start vector generation = ', f12.6,/ +- & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ +- & 5x, 'Total time in getting the shifts = ', f12.6,/ +- & 5x, 'Total time in applying the shifts = ', f12.6,/ +- & 5x, 'Total time in convergence testing = ', f12.6,/ +- & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of snaupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snconv.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snconv.f +deleted file mode 100644 +index af94700a93..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/snconv.f ++++ /dev/null +@@ -1,146 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: snconv +-c +-c\Description: +-c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. +-c +-c\Usage: +-c call snconv +-c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Number of Ritz values to check for convergence. +-c +-c RITZR, Real arrays of length N. (INPUT) +-c RITZI Real and imaginary parts of the Ritz values to be checked +-c for convergence. +- +-c BOUNDS Real array of length N. (INPUT) +-c Ritz estimates for the Ritz values in RITZR and RITZI. +-c +-c TOL Real scalar. (INPUT) +-c Desired backward error for a Ritz value to be considered +-c "converged". +-c +-c NCONV Integer scalar. (OUTPUT) +-c Number of "converged" Ritz values. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c slamch LAPACK routine that determines machine constants. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c 1. xxxx +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine snconv (n, ritzr, ritzi, bounds, tol, nconv) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer n, nconv +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +- +- Real +- & ritzr(n), ritzi(n), bounds(n) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i +- Real +- & temp, eps23 +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slapy2, slamch +- external slapy2, slamch +- +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------------------------------------% +-c | Convergence test: unlike in the symmetric code, I am not | +-c | using things like refined error bounds and gap condition | +-c | because I don't know the exact equivalent concept. | +-c | | +-c | Instead the i-th Ritz value is considered "converged" when: | +-c | | +-c | bounds(i) .le. ( TOL * | ritz | ) | +-c | | +-c | for some appropriate choice of norm. | +-c %-------------------------------------------------------------% +-c +- call arscnd (t0) +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0) +-c +- nconv = 0 +- do 20 i = 1, n +- temp = max( eps23, slapy2( ritzr(i), ritzi(i) ) ) +- if (bounds(i) .le. tol*temp) nconv = nconv + 1 +- 20 continue +-c +- call arscnd (t1) +- tnconv = tnconv + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of snconv | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneigh.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneigh.f +deleted file mode 100644 +index 7ffb48658e..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneigh.f ++++ /dev/null +@@ -1,318 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: sneigh +-c +-c\Description: +-c Compute the eigenvalues of the current upper Hessenberg matrix +-c and the corresponding Ritz estimates given the current residual norm. +-c +-c\Usage: +-c call sneigh +-c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) +-c +-c\Arguments +-c RNORM Real scalar. (INPUT) +-c Residual norm corresponding to the current upper Hessenberg +-c matrix H. +-c +-c N Integer. (INPUT) +-c Size of the matrix H. +-c +-c H Real N by N array. (INPUT) +-c H contains the current upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZR, Real arrays of length N. (OUTPUT) +-c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real +-c (respectively imaginary) parts of the eigenvalues of H. +-c +-c BOUNDS Real array of length N. (OUTPUT) +-c On output, BOUNDS contains the Ritz estimates associated with +-c the eigenvalues RITZR and RITZI. This is equal to RNORM +-c times the last components of the eigenvectors corresponding +-c to the eigenvalues in RITZR and RITZI. +-c +-c Q Real N by N array. (WORKSPACE) +-c Workspace needed to store the eigenvectors of H. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Real work array of length N**2 + 3*N. (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. This is needed to keep the full Schur form +-c of H and also in the calculation of the eigenvectors of H. +-c +-c IERR Integer. (OUTPUT) +-c Error exit flag from slahqr or strevc. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c slahqr LAPACK routine to compute the real Schur form of an +-c upper Hessenberg matrix and last row of the Schur vectors. +-c arscnd ARPACK utility routine for timing. +-c smout ARPACK utility routine that prints matrices +-c svout ARPACK utility routine that prints vectors. +-c slacpy LAPACK matrix copy routine. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c strevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper quasi-triangular form +-c sgemv Level 2 BLAS routine for matrix vector multiplication. +-c scopy Level 1 BLAS that copies one vector to another . +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c sscal Level 1 BLAS that scales a vector. +-c +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine sneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, +- & q, ldq, workl, ierr) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer ierr, n, ldh, ldq +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), +- & workl(n*(n+3)) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical select(1) +- integer i, iconj, msglvl +- Real +- & temp, vl(1) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy, slacpy, slahqr, strevc, svout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slapy2, snrm2 +- external slapy2, snrm2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mneigh +-c +- if (msglvl .gt. 2) then +- call smout (logfil, n, n, h, ldh, ndigit, +- & '_neigh: Entering upper Hessenberg matrix H ') +- end if +-c +-c %-----------------------------------------------------------% +-c | 1. Compute the eigenvalues, the last components of the | +-c | corresponding Schur vectors and the full Schur form T | +-c | of the current upper Hessenberg matrix H. | +-c | slahqr returns the full Schur form of H in WORKL(1:N**2) | +-c | and the last components of the Schur vectors in BOUNDS. | +-c %-----------------------------------------------------------% +-c +- call slacpy ('All', n, n, h, ldh, workl, n) +- do 5 j = 1, n-1 +- bounds(j) = zero +- 5 continue +- bounds(n) = one +- call slahqr(.true., .true., n, 1, n, workl, n, ritzr, ritzi, 1, 1, +- & bounds, 1, ierr) +- if (ierr .ne. 0) go to 9000 +-c +- if (msglvl .gt. 1) then +- call svout (logfil, n, bounds, ndigit, +- & '_neigh: last row of the Schur matrix for H') +- end if +-c +-c %-----------------------------------------------------------% +-c | 2. Compute the eigenvectors of the full Schur form T and | +-c | apply the last components of the Schur vectors to get | +-c | the last components of the corresponding eigenvectors. | +-c | Remember that if the i-th and (i+1)-st eigenvalues are | +-c | complex conjugate pairs, then the real & imaginary part | +-c | of the eigenvector components are split across adjacent | +-c | columns of Q. | +-c %-----------------------------------------------------------% +-c +- call strevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, +- & n, n, workl(n*n+1), ierr) +-c +- if (ierr .ne. 0) go to 9000 +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | euclidean norms are all one. LAPACK subroutine | +-c | strevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1; here the magnitude of a complex | +-c | number (x,y) is taken to be |x| + |y|. | +-c %------------------------------------------------% +-c +- iconj = 0 +- do 10 i=1, n +- if ( abs( ritzi(i) ) .le. zero ) then +-c +-c %----------------------% +-c | Real eigenvalue case | +-c %----------------------% +-c +- temp = snrm2( n, q(1,i), 1 ) +- call sscal ( n, one / temp, q(1,i), 1 ) +- else +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c | columns, we further normalize by the | +-c | square root of two. | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- temp = slapy2( snrm2( n, q(1,i), 1 ), +- & snrm2( n, q(1,i+1), 1 ) ) +- call sscal ( n, one / temp, q(1,i), 1 ) +- call sscal ( n, one / temp, q(1,i+1), 1 ) +- iconj = 1 +- else +- iconj = 0 +- end if +- end if +- 10 continue +-c +- call sgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) +-c +- if (msglvl .gt. 1) then +- call svout (logfil, n, workl, ndigit, +- & '_neigh: Last row of the eigenvector matrix for H') +- end if +-c +-c %----------------------------% +-c | Compute the Ritz estimates | +-c %----------------------------% +-c +- iconj = 0 +- do 20 i = 1, n +- if ( abs( ritzi(i) ) .le. zero ) then +-c +-c %----------------------% +-c | Real eigenvalue case | +-c %----------------------% +-c +- bounds(i) = rnorm * abs( workl(i) ) +- else +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c | columns, we need to take the magnitude | +-c | of the last components of the two vectors | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- bounds(i) = rnorm * slapy2( workl(i), workl(i+1) ) +- bounds(i+1) = bounds(i) +- iconj = 1 +- else +- iconj = 0 +- end if +- end if +- 20 continue +-c +- if (msglvl .gt. 2) then +- call svout (logfil, n, ritzr, ndigit, +- & '_neigh: Real part of the eigenvalues of H') +- call svout (logfil, n, ritzi, ndigit, +- & '_neigh: Imaginary part of the eigenvalues of H') +- call svout (logfil, n, bounds, ndigit, +- & '_neigh: Ritz estimates for the eigenvalues of H') +- end if +-c +- call arscnd (t1) +- tneigh = tneigh + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of sneigh | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneupd.f +deleted file mode 100644 +index 1c2c7ce16c..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sneupd.f ++++ /dev/null +@@ -1,1070 +0,0 @@ +-c\BeginDoc +-c +-c\Name: sneupd +-c +-c\Description: +-c +-c This subroutine returns the converged approximations to eigenvalues +-c of A*z = lambda*B*z and (optionally): +-c +-c (1) The corresponding approximate eigenvectors; +-c +-c (2) An orthonormal basis for the associated approximate +-c invariant subspace; +-c +-c (3) Both. +-c +-c There is negligible additional cost to obtain eigenvectors. An orthonormal +-c basis is always computed. There is an additional storage cost of n*nev +-c if both are requested (in this case a separate array Z must be supplied). +-c +-c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z +-c are derived from approximate eigenvalues and eigenvectors of +-c of the linear operator OP prescribed by the MODE selection in the +-c call to SNAUPD. SNAUPD must be called before this routine is called. +-c These approximate eigenvalues and vectors are commonly called Ritz +-c values and Ritz vectors respectively. They are referred to as such +-c in the comments that follow. The computed orthonormal basis for the +-c invariant subspace corresponding to these Ritz values is referred to as a +-c Schur basis. +-c +-c See documentation in the header of the subroutine SNAUPD for +-c definition of OP as well as other terms and the relation of computed +-c Ritz values and Ritz vectors of OP with respect to the given problem +-c A*z = lambda*B*z. For a brief description, see definitions of +-c IPARAM(7), MODE and WHICH in the documentation of SNAUPD. +-c +-c\Usage: +-c call sneupd +-c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, +-c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, +-c LWORKL, INFO ) +-c +-c\Arguments: +-c RVEC LOGICAL (INPUT) +-c Specifies whether a basis for the invariant subspace corresponding +-c to the converged Ritz value approximations for the eigenproblem +-c A*z = lambda*B*z is computed. +-c +-c RVEC = .FALSE. Compute Ritz values only. +-c +-c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. +-c See Remarks below. +-c +-c HOWMNY Character*1 (INPUT) +-c Specifies the form of the basis for the invariant subspace +-c corresponding to the converged Ritz values that is to be computed. +-c +-c = 'A': Compute NEV Ritz vectors; +-c = 'P': Compute NEV Schur vectors; +-c = 'S': compute some of the Ritz vectors, specified +-c by the logical array SELECT. +-c +-c SELECT Logical array of dimension NCV. (INPUT) +-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +-c computed. To select the Ritz vector corresponding to a +-c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. +-c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. +-c +-c DR Real array of dimension NEV+1. (OUTPUT) +-c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains +-c the real part of the Ritz approximations to the eigenvalues of +-c A*z = lambda*B*z. +-c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: +-c DR contains the real part of the Ritz values of OP computed by +-c SNAUPD. A further computation must be performed by the user +-c to transform the Ritz values computed for OP by SNAUPD to those +-c of the original system A*z = lambda*B*z. See remark 3 below. +-c +-c DI Real array of dimension NEV+1. (OUTPUT) +-c On exit, DI contains the imaginary part of the Ritz value +-c approximations to the eigenvalues of A*z = lambda*B*z associated +-c with DR. +-c +-c NOTE: When Ritz values are complex, they will come in complex +-c conjugate pairs. If eigenvectors are requested, the +-c corresponding Ritz vectors will also come in conjugate +-c pairs and the real and imaginary parts of these are +-c represented in two consecutive columns of the array Z +-c (see below). +-c +-c Z Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) +-c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of +-c Z represent approximate eigenvectors (Ritz vectors) corresponding +-c to the NCONV=IPARAM(5) Ritz values for eigensystem +-c A*z = lambda*B*z. +-c +-c The complex Ritz vector associated with the Ritz value +-c with positive imaginary part is stored in two consecutive +-c columns. The first column holds the real part of the Ritz +-c vector and the second column holds the imaginary part. The +-c Ritz vector associated with the Ritz value with negative +-c imaginary part is simply the complex conjugate of the Ritz vector +-c associated with the positive imaginary part. +-c +-c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. +-c +-c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, +-c the array Z may be set equal to first NEV+1 columns of the Arnoldi +-c basis array V computed by SNAUPD. In this case the Arnoldi basis +-c will be destroyed and overwritten with the eigenvector basis. +-c +-c LDZ Integer. (INPUT) +-c The leading dimension of the array Z. If Ritz vectors are +-c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. +-c +-c SIGMAR Real (INPUT) +-c If IPARAM(7) = 3 or 4, represents the real part of the shift. +-c Not referenced if IPARAM(7) = 1 or 2. +-c +-c SIGMAI Real (INPUT) +-c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. +-c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. +-c +-c WORKEV Real work array of dimension 3*NCV. (WORKSPACE) +-c +-c **** The remaining arguments MUST be the same as for the **** +-c **** call to SNAUPD that was just completed. **** +-c +-c NOTE: The remaining arguments +-c +-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +-c WORKD, WORKL, LWORKL, INFO +-c +-c must be passed directly to SNEUPD following the last call +-c to SNAUPD. These arguments MUST NOT BE MODIFIED between +-c the the last call to SNAUPD and the call to SNEUPD. +-c +-c Three of these parameters (V, WORKL, INFO) are also output parameters: +-c +-c V Real N by NCV array. (INPUT/OUTPUT) +-c +-c Upon INPUT: the NCV columns of V contain the Arnoldi basis +-c vectors for OP as constructed by SNAUPD . +-c +-c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns +-c contain approximate Schur vectors that span the +-c desired invariant subspace. See Remark 2 below. +-c +-c NOTE: If the array Z has been set equal to first NEV+1 columns +-c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the +-c Arnoldi basis held by V has been overwritten by the desired +-c Ritz vectors. If a separate array Z has been passed then +-c the first NCONV=IPARAM(5) columns of V will contain approximate +-c Schur vectors that span the desired invariant subspace. +-c +-c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) +-c WORKL(1:ncv*ncv+3*ncv) contains information obtained in +-c snaupd. They are not changed by sneupd. +-c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the +-c real and imaginary part of the untransformed Ritz values, +-c the upper quasi-triangular matrix for H, and the +-c associated matrix representation of the invariant subspace for H. +-c +-c Note: IPNTR(9:13) contains the pointer into WORKL for addresses +-c of the above information computed by sneupd. +-c ------------------------------------------------------------- +-c IPNTR(9): pointer to the real part of the NCV RITZ values of the +-c original system. +-c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of +-c the original system. +-c IPNTR(11): pointer to the NCV corresponding error bounds. +-c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c sneupd if RVEC = .TRUE. See Remark 2 below. +-c ------------------------------------------------------------- +-c +-c INFO Integer. (OUTPUT) +-c Error flag on output. +-c +-c = 0: Normal exit. +-c +-c = 1: The Schur form computed by LAPACK routine slahqr +-c could not be reordered by LAPACK routine strsen. +-c Re-enter subroutine sneupd with IPARAM(5)=NCV and +-c increase the size of the arrays DR and DI to have +-c dimension at least dimension NCV and allocate at least NCV +-c columns for Z. NOTE: Not necessary if Z and V share +-c the same space. Please notify the authors if this error +-c occurs. +-c +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work WORKL array is not sufficient. +-c = -8: Error return from calculation of a real Schur form. +-c Informational error from LAPACK routine slahqr. +-c = -9: Error return from calculation of eigenvectors. +-c Informational error from LAPACK routine strevc. +-c = -10: IPARAM(7) must be 1,2,3,4. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: HOWMNY = 'S' not yet implemented +-c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. +-c = -14: SNAUPD did not find any eigenvalues to sufficient +-c accuracy. +-c = -15: DNEUPD got a different count of the number of converged +-c Ritz values than DNAUPD got. This indicates the user +-c probably made an error in passing data from DNAUPD to +-c DNEUPD or that the data was modified before entering +-c DNEUPD +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for +-c Real Matrices", Linear Algebra and its Applications, vol 88/89, +-c pp 575-595, (1987). +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c smout ARPACK utility routine that prints matrices +-c svout ARPACK utility routine that prints vectors. +-c sgeqr2 LAPACK routine that computes the QR factorization of +-c a matrix. +-c slacpy LAPACK matrix copy routine. +-c slahqr LAPACK routine to compute the real Schur form of an +-c upper Hessenberg matrix. +-c slamch LAPACK routine that determines machine constants. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c slaset LAPACK matrix initialization routine. +-c sorm2r LAPACK routine that applies an orthogonal matrix in +-c factored form. +-c strevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper quasi-triangular form. +-c strsen LAPACK routine that re-orders the Schur form. +-c strmm Level 3 BLAS matrix times an upper triangular matrix. +-c sger Level 2 BLAS rank one update to a matrix. +-c scopy Level 1 BLAS that copies one vector to another . +-c sdot Level 1 BLAS that computes the scalar product of two vectors. +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c sscal Level 1 BLAS that scales a vector. +-c +-c\Remarks +-c +-c 1. Currently only HOWMNY = 'A' and 'P' are implemented. +-c +-c Let trans(X) denote the transpose of X. +-c +-c 2. Schur vectors are an orthogonal representation for the basis of +-c Ritz vectors. Thus, their numerical properties are often superior. +-c If RVEC = .TRUE. then the relationship +-c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and +-c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately +-c satisfied. Here T is the leading submatrix of order IPARAM(5) of the +-c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, +-c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; +-c each 2-by-2 diagonal block has its diagonal elements equal and its +-c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 +-c diagonal block is a complex conjugate pair of Ritz values. The real +-c Ritz values are stored on the diagonal of T. +-c +-c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must +-c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz +-c values computed by SNAUPD for OP to those of A*z = lambda*B*z. +-c Set RVEC = .true. and HOWMNY = 'A', and +-c compute +-c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. +-c If DI(I) is not equal to zero and DI(I+1) = - D(I), +-c then the desired real and imaginary parts of the Ritz value are +-c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), +-c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), +-c respectively. +-c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and +-c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper +-c quasi-triangular matrix of order IPARAM(5) is computed. See remark +-c 2 above. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +- subroutine sneupd(rvec , howmny, select, dr , di, +- & z , ldz , sigmar, sigmai, workev, +- & bmat , n , which , nev , tol, +- & resid, ncv , v , ldv , iparam, +- & ipntr, workd , workl , lworkl, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat, howmny, which*2 +- logical rvec +- integer info, ldz, ldv, lworkl, n, ncv, nev +- Real +- & sigmar, sigmai, tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- logical select(ncv) +- Real +- & dr(nev+1) , di(nev+1), resid(n) , +- & v(ldv,ncv) , z(ldz,*) , workd(3*n), +- & workl(lworkl), workev(3*ncv) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0 , zero = 0.0E+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character type*6 +- integer bounds, ierr , ih , ihbds , +- & iheigr, iheigi, iconj , nconv , +- & invsub, iuptri, iwev , iwork(1), +- & j , k , ldh , ldq , +- & mode , msglvl, outncv, ritzr , +- & ritzi , wri , wrr , irr , +- & iri , ibd , ishift, numcnv , +- & np , jj , nconv2 +- logical reord +- Real +- & conds , rnorm, sep , temp, +- & vl(1,1), temp1, eps23 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy , sger , sgeqr2, slacpy, +- & slahqr, slaset, smout , sorm2r, +- & strevc, strmm , strsen, sscal , +- & svout , ivout +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slapy2, snrm2, slamch, sdot +- external slapy2, snrm2, slamch, sdot +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs, min, sqrt +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- msglvl = mneupd +- mode = iparam(7) +- nconv = iparam(5) +- info = 0 +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0 ) +-c +-c %--------------% +-c | Quick return | +-c %--------------% +-c +- ierr = 0 +-c +- if (nconv .le. 0) then +- ierr = -14 +- else if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev+1 .or. ncv .gt. n) then +- ierr = -3 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 6*ncv) then +- ierr = -7 +- else if ( (howmny .ne. 'A' .and. +- & howmny .ne. 'P' .and. +- & howmny .ne. 'S') .and. rvec ) then +- ierr = -13 +- else if (howmny .eq. 'S' ) then +- ierr = -12 +- end if +-c +- if (mode .eq. 1 .or. mode .eq. 2) then +- type = 'REGULR' +- else if (mode .eq. 3 .and. sigmai .eq. zero) then +- type = 'SHIFTI' +- else if (mode .eq. 3 ) then +- type = 'REALPT' +- else if (mode .eq. 4 ) then +- type = 'IMAGPT' +- else +- ierr = -10 +- end if +- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | +-c | parts of ritz values | +-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | +-c %--------------------------------------------------------% +-c +-c %-----------------------------------------------------------% +-c | The following is used and set by SNEUPD. | +-c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | +-c | real part of the Ritz values. | +-c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | +-c | imaginary part of the Ritz values. | +-c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | +-c | error bounds of the Ritz values | +-c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | +-c | quasi-triangular matrix for H | +-c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | +-c | associated matrix representation of the invariant | +-c | subspace for H. | +-c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | +-c %-----------------------------------------------------------% +-c +- ih = ipntr(5) +- ritzr = ipntr(6) +- ritzi = ipntr(7) +- bounds = ipntr(8) +- ldh = ncv +- ldq = ncv +- iheigr = bounds + ldh +- iheigi = iheigr + ldh +- ihbds = iheigi + ldh +- iuptri = ihbds + ldh +- invsub = iuptri + ldh*ncv +- ipntr(9) = iheigr +- ipntr(10) = iheigi +- ipntr(11) = ihbds +- ipntr(12) = iuptri +- ipntr(13) = invsub +- wrr = 1 +- wri = ncv + 1 +- iwev = wri + ncv +-c +-c %-----------------------------------------% +-c | irr points to the REAL part of the Ritz | +-c | values computed by _neigh before | +-c | exiting _naup2. | +-c | iri points to the IMAGINARY part of the | +-c | Ritz values computed by _neigh | +-c | before exiting _naup2. | +-c | ibd points to the Ritz estimates | +-c | computed by _neigh before exiting | +-c | _naup2. | +-c %-----------------------------------------% +-c +- irr = ipntr(14)+ncv*ncv +- iri = irr+ncv +- ibd = iri+ncv +-c +-c %------------------------------------% +-c | RNORM is B-norm of the RESID(1:N). | +-c %------------------------------------% +-c +- rnorm = workl(ih+2) +- workl(ih+2) = zero +-c +- if (msglvl .gt. 2) then +- call svout(logfil, ncv, workl(irr), ndigit, +- & '_neupd: Real part of Ritz values passed in from _NAUPD.') +- call svout(logfil, ncv, workl(iri), ndigit, +- & '_neupd: Imag part of Ritz values passed in from _NAUPD.') +- call svout(logfil, ncv, workl(ibd), ndigit, +- & '_neupd: Ritz estimates passed in from _NAUPD.') +- end if +-c +- if (rvec) then +-c +- reord = .false. +-c +-c %---------------------------------------------------% +-c | Use the temporary bounds array to store indices | +-c | These will be used to mark the select array later | +-c %---------------------------------------------------% +-c +- do 10 j = 1,ncv +- workl(bounds+j-1) = j +- select(j) = .false. +- 10 continue +-c +-c %-------------------------------------% +-c | Select the wanted Ritz values. | +-c | Sort the Ritz values so that the | +-c | wanted ones appear at the tailing | +-c | NEV positions of workl(irr) and | +-c | workl(iri). Move the corresponding | +-c | error estimates in workl(bound) | +-c | accordingly. | +-c %-------------------------------------% +-c +- np = ncv - nev +- ishift = 0 +- call sngets(ishift , which , nev , +- & np , workl(irr), workl(iri), +- & workl(bounds), workl , workl(np+1)) +-c +- if (msglvl .gt. 2) then +- call svout(logfil, ncv, workl(irr), ndigit, +- & '_neupd: Real part of Ritz values after calling _NGETS.') +- call svout(logfil, ncv, workl(iri), ndigit, +- & '_neupd: Imag part of Ritz values after calling _NGETS.') +- call svout(logfil, ncv, workl(bounds), ndigit, +- & '_neupd: Ritz value indices after calling _NGETS.') +- end if +-c +-c %-----------------------------------------------------% +-c | Record indices of the converged wanted Ritz values | +-c | Mark the select array for possible reordering | +-c %-----------------------------------------------------% +-c +- numcnv = 0 +- do 11 j = 1,ncv +- temp1 = max(eps23, +- & slapy2( workl(irr+ncv-j), workl(iri+ncv-j) )) +- jj = workl(bounds + ncv - j) +- if (numcnv .lt. nconv .and. +- & workl(ibd+jj-1) .le. tol*temp1) then +- select(jj) = .true. +- numcnv = numcnv + 1 +- if (jj .gt. nconv) reord = .true. +- endif +- 11 continue +-c +-c %-----------------------------------------------------------% +-c | Check the count (numcnv) of converged Ritz values with | +-c | the number (nconv) reported by dnaupd. If these two | +-c | are different then there has probably been an error | +-c | caused by incorrect passing of the dnaupd data. | +-c %-----------------------------------------------------------% +-c +- if (msglvl .gt. 2) then +- call ivout(logfil, 1, [numcnv], ndigit, +- & '_neupd: Number of specified eigenvalues') +- call ivout(logfil, 1, [nconv], ndigit, +- & '_neupd: Number of "converged" eigenvalues') +- end if +-c +- if (numcnv .ne. nconv) then +- info = -15 +- go to 9000 +- end if +-c +-c %-----------------------------------------------------------% +-c | Call LAPACK routine slahqr to compute the real Schur form | +-c | of the upper Hessenberg matrix returned by SNAUPD. | +-c | Make a copy of the upper Hessenberg matrix. | +-c | Initialize the Schur vector matrix Q to the identity. | +-c %-----------------------------------------------------------% +-c +- call scopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) +- call slaset('All', ncv, ncv, +- & zero , one, workl(invsub), +- & ldq) +- call slahqr(.true., .true. , ncv, +- & 1 , ncv , workl(iuptri), +- & ldh , workl(iheigr), workl(iheigi), +- & 1 , ncv , workl(invsub), +- & ldq , ierr) +- call scopy(ncv , workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 9000 +- end if +-c +- if (msglvl .gt. 1) then +- call svout(logfil, ncv, workl(iheigr), ndigit, +- & '_neupd: Real part of the eigenvalues of H') +- call svout(logfil, ncv, workl(iheigi), ndigit, +- & '_neupd: Imaginary part of the Eigenvalues of H') +- call svout(logfil, ncv, workl(ihbds), ndigit, +- & '_neupd: Last row of the Schur vector matrix') +- if (msglvl .gt. 3) then +- call smout(logfil , ncv, ncv , +- & workl(iuptri), ldh, ndigit, +- & '_neupd: The upper quasi-triangular matrix ') +- end if +- end if +-c +- if (reord) then +-c +-c %-----------------------------------------------------% +-c | Reorder the computed upper quasi-triangular matrix. | +-c %-----------------------------------------------------% +-c +- call strsen('None' , 'V' , +- & select , ncv , +- & workl(iuptri), ldh , +- & workl(invsub), ldq , +- & workl(iheigr), workl(iheigi), +- & nconv2 , conds , +- & sep , workl(ihbds) , +- & ncv , iwork , +- & 1 , ierr) +-c +- if (nconv2 .lt. nconv) then +- nconv = nconv2 +- end if +- +- if (ierr .eq. 1) then +- info = 1 +- go to 9000 +- end if +-c +- if (msglvl .gt. 2) then +- call svout(logfil, ncv, workl(iheigr), ndigit, +- & '_neupd: Real part of the eigenvalues of H--reordered') +- call svout(logfil, ncv, workl(iheigi), ndigit, +- & '_neupd: Imag part of the eigenvalues of H--reordered') +- if (msglvl .gt. 3) then +- call smout(logfil , ncv, ncv , +- & workl(iuptri), ldq, ndigit, +- & '_neupd: Quasi-triangular matrix after re-ordering') +- end if +- end if +-c +- end if +-c +-c %---------------------------------------% +-c | Copy the last row of the Schur vector | +-c | into workl(ihbds). This will be used | +-c | to compute the Ritz estimates of | +-c | converged Ritz values. | +-c %---------------------------------------% +-c +- call scopy(ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) +-c +-c %----------------------------------------------------% +-c | Place the computed eigenvalues of H into DR and DI | +-c | if a spectral transformation was not used. | +-c %----------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +- call scopy(nconv, workl(iheigr), 1, dr, 1) +- call scopy(nconv, workl(iheigi), 1, di, 1) +- end if +-c +-c %----------------------------------------------------------% +-c | Compute the QR factorization of the matrix representing | +-c | the wanted invariant subspace located in the first NCONV | +-c | columns of workl(invsub,ldq). | +-c %----------------------------------------------------------% +-c +- call sgeqr2(ncv, nconv , workl(invsub), +- & ldq, workev, workev(ncv+1), +- & ierr) +-c +-c %---------------------------------------------------------% +-c | * Postmultiply V by Q using sorm2r. | +-c | * Copy the first NCONV columns of VQ into Z. | +-c | * Postmultiply Z by R. | +-c | The N by NCONV matrix Z is now a matrix representation | +-c | of the approximate invariant subspace associated with | +-c | the Ritz values in workl(iheigr) and workl(iheigi) | +-c | The first NCONV columns of V are now approximate Schur | +-c | vectors associated with the real upper quasi-triangular | +-c | matrix of order NCONV in workl(iuptri) | +-c %---------------------------------------------------------% +-c +- call sorm2r('Right', 'Notranspose', n , +- & ncv , nconv , workl(invsub), +- & ldq , workev , v , +- & ldv , workd(n+1) , ierr) +- call slacpy('All', n, nconv, v, ldv, z, ldz) +-c +- do 20 j=1, nconv +-c +-c %---------------------------------------------------% +-c | Perform both a column and row scaling if the | +-c | diagonal element of workl(invsub,ldq) is negative | +-c | I'm lazy and don't take advantage of the upper | +-c | quasi-triangular form of workl(iuptri,ldq) | +-c | Note that since Q is orthogonal, R is a diagonal | +-c | matrix consisting of plus or minus ones | +-c %---------------------------------------------------% +-c +- if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then +- call sscal(nconv, -one, workl(iuptri+j-1), ldq) +- call sscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) +- end if +-c +- 20 continue +-c +- if (howmny .eq. 'A') then +-c +-c %--------------------------------------------% +-c | Compute the NCONV wanted eigenvectors of T | +-c | located in workl(iuptri,ldq). | +-c %--------------------------------------------% +-c +- do 30 j=1, ncv +- if (j .le. nconv) then +- select(j) = .true. +- else +- select(j) = .false. +- end if +- 30 continue +-c +- call strevc('Right', 'Select' , select , +- & ncv , workl(iuptri), ldq , +- & vl , 1 , workl(invsub), +- & ldq , ncv , outncv , +- & workev , ierr) +-c +- if (ierr .ne. 0) then +- info = -9 +- go to 9000 +- end if +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | Euclidean norms are all one. LAPACK subroutine | +-c | strevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1; | +-c %------------------------------------------------% +-c +- iconj = 0 +- do 40 j=1, nconv +-c +- if ( workl(iheigi+j-1) .eq. zero ) then +-c +-c %----------------------% +-c | real eigenvalue case | +-c %----------------------% +-c +- temp = snrm2( ncv, workl(invsub+(j-1)*ldq), 1 ) +- call sscal( ncv, one / temp, +- & workl(invsub+(j-1)*ldq), 1 ) +-c +- else +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c | columns, we further normalize by the | +-c | square root of two. | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- temp = slapy2(snrm2(ncv, +- & workl(invsub+(j-1)*ldq), +- & 1), +- & snrm2(ncv, +- & workl(invsub+j*ldq), +- & 1)) +- call sscal(ncv, one/temp, +- & workl(invsub+(j-1)*ldq), 1 ) +- call sscal(ncv, one/temp, +- & workl(invsub+j*ldq), 1 ) +- iconj = 1 +- else +- iconj = 0 +- end if +-c +- end if +-c +- 40 continue +-c +- call sgemv('T', ncv, nconv, one, workl(invsub), +- & ldq, workl(ihbds), 1, zero, workev, 1) +-c +- iconj = 0 +- do 45 j=1, nconv +- if (workl(iheigi+j-1) .ne. zero) then +-c +-c %-------------------------------------------% +-c | Complex conjugate pair case. Note that | +-c | since the real and imaginary part of | +-c | the eigenvector are stored in consecutive | +-c %-------------------------------------------% +-c +- if (iconj .eq. 0) then +- workev(j) = slapy2(workev(j), workev(j+1)) +- workev(j+1) = workev(j) +- iconj = 1 +- else +- iconj = 0 +- end if +- end if +- 45 continue +-c +- if (msglvl .gt. 2) then +- call scopy(ncv, workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +- call svout(logfil, ncv, workl(ihbds), ndigit, +- & '_neupd: Last row of the eigenvector matrix for T') +- if (msglvl .gt. 3) then +- call smout(logfil, ncv, ncv, workl(invsub), ldq, +- & ndigit, '_neupd: The eigenvector matrix for T') +- end if +- end if +-c +-c %---------------------------------------% +-c | Copy Ritz estimates into workl(ihbds) | +-c %---------------------------------------% +-c +- call scopy(nconv, workev, 1, workl(ihbds), 1) +-c +-c %---------------------------------------------------------% +-c | Compute the QR factorization of the eigenvector matrix | +-c | associated with leading portion of T in the first NCONV | +-c | columns of workl(invsub,ldq). | +-c %---------------------------------------------------------% +-c +- call sgeqr2(ncv, nconv , workl(invsub), +- & ldq, workev, workev(ncv+1), +- & ierr) +-c +-c %----------------------------------------------% +-c | * Postmultiply Z by Q. | +-c | * Postmultiply Z by R. | +-c | The N by NCONV matrix Z is now contains the | +-c | Ritz vectors associated with the Ritz values | +-c | in workl(iheigr) and workl(iheigi). | +-c %----------------------------------------------% +-c +- call sorm2r('Right', 'Notranspose', n , +- & ncv , nconv , workl(invsub), +- & ldq , workev , z , +- & ldz , workd(n+1) , ierr) +-c +- call strmm('Right' , 'Upper' , 'No transpose', +- & 'Non-unit', n , nconv , +- & one , workl(invsub), ldq , +- & z , ldz) +-c +- end if +-c +- else +-c +-c %------------------------------------------------------% +-c | An approximate invariant subspace is not needed. | +-c | Place the Ritz values computed SNAUPD into DR and DI | +-c %------------------------------------------------------% +-c +- call scopy(nconv, workl(ritzr), 1, dr, 1) +- call scopy(nconv, workl(ritzi), 1, di, 1) +- call scopy(nconv, workl(ritzr), 1, workl(iheigr), 1) +- call scopy(nconv, workl(ritzi), 1, workl(iheigi), 1) +- call scopy(nconv, workl(bounds), 1, workl(ihbds), 1) +- end if +-c +-c %------------------------------------------------% +-c | Transform the Ritz values and possibly vectors | +-c | and corresponding error bounds of OP to those | +-c | of A*x = lambda*B*x. | +-c %------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +-c +- if (rvec) +- & call sscal(ncv, rnorm, workl(ihbds), 1) +-c +- else +-c +-c %---------------------------------------% +-c | A spectral transformation was used. | +-c | * Determine the Ritz estimates of the | +-c | Ritz values in the original system. | +-c %---------------------------------------% +-c +- if (type .eq. 'SHIFTI') then +-c +- if (rvec) +- & call sscal(ncv, rnorm, workl(ihbds), 1) +-c +- do 50 k=1, ncv +- temp = slapy2( workl(iheigr+k-1), +- & workl(iheigi+k-1) ) +- workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) +- & / temp / temp +- 50 continue +-c +- else if (type .eq. 'REALPT') then +-c +- do 60 k=1, ncv +- 60 continue +-c +- else if (type .eq. 'IMAGPT') then +-c +- do 70 k=1, ncv +- 70 continue +-c +- end if +-c +-c %-----------------------------------------------------------% +-c | * Transform the Ritz values back to the original system. | +-c | For TYPE = 'SHIFTI' the transformation is | +-c | lambda = 1/theta + sigma | +-c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | +-c | Rayleigh quotients or a projection. See remark 3 above.| +-c | NOTES: | +-c | *The Ritz vectors are not affected by the transformation. | +-c %-----------------------------------------------------------% +-c +- if (type .eq. 'SHIFTI') then +-c +- do 80 k=1, ncv +- temp = slapy2( workl(iheigr+k-1), +- & workl(iheigi+k-1) ) +- workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp +- & + sigmar +- workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp +- & + sigmai +- 80 continue +-c +- call scopy(nconv, workl(iheigr), 1, dr, 1) +- call scopy(nconv, workl(iheigi), 1, di, 1) +-c +- else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then +-c +- call scopy(nconv, workl(iheigr), 1, dr, 1) +- call scopy(nconv, workl(iheigi), 1, di, 1) +-c +- end if +-c +- end if +-c +- if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then +- call svout(logfil, nconv, dr, ndigit, +- & '_neupd: Untransformed real part of the Ritz values.') +- call svout (logfil, nconv, di, ndigit, +- & '_neupd: Untransformed imag part of the Ritz values.') +- call svout(logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Ritz estimates of untransformed Ritz values.') +- else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then +- call svout(logfil, nconv, dr, ndigit, +- & '_neupd: Real parts of converged Ritz values.') +- call svout (logfil, nconv, di, ndigit, +- & '_neupd: Imag parts of converged Ritz values.') +- call svout(logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Associated Ritz estimates.') +- end if +-c +-c %-------------------------------------------------% +-c | Eigenvector Purification step. Formally perform | +-c | one of inverse subspace iteration. Only used | +-c | for MODE = 2. | +-c %-------------------------------------------------% +-c +- if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then +-c +-c %------------------------------------------------% +-c | Purify the computed Ritz vectors by adding a | +-c | little bit of the residual vector: | +-c | T | +-c | resid(:)*( e s ) / theta | +-c | NCV | +-c | where H s = s theta. Remember that when theta | +-c | has nonzero imaginary part, the corresponding | +-c | Ritz vector is stored across two columns of Z. | +-c %------------------------------------------------% +-c +- iconj = 0 +- do 110 j=1, nconv +- if ((workl(iheigi+j-1) .eq. zero) .and. +- & (workl(iheigr+j-1) .ne. zero)) then +- workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / +- & workl(iheigr+j-1) +- else if (iconj .eq. 0) then +- temp = slapy2( workl(iheigr+j-1), workl(iheigi+j-1) ) +- if (temp. ne. zero) then +- workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * +- & workl(iheigr+j-1) + +- & workl(invsub+j*ldq+ncv-1) * +- & workl(iheigi+j-1) ) / temp / temp +- workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * +- & workl(iheigr+j-1) - +- & workl(invsub+(j-1)*ldq+ncv-1) * +- & workl(iheigi+j-1) ) / temp / temp +- end if +- iconj = 1 +- else +- iconj = 0 +- end if +- 110 continue +-c +-c %---------------------------------------% +-c | Perform a rank one update to Z and | +-c | purify all the Ritz vectors together. | +-c %---------------------------------------% +-c +- call sger(n, nconv, one, resid, 1, workev, 1, z, ldz) +-c +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of SNEUPD | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sngets.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sngets.f +deleted file mode 100644 +index 7e48c0bb18..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sngets.f ++++ /dev/null +@@ -1,231 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: sngets +-c +-c\Description: +-c Given the eigenvalues of the upper Hessenberg matrix H, +-c computes the NP shifts AMU that are zeros of the polynomial of +-c degree NP which filters out components of the unwanted eigenvectors +-c corresponding to the AMU's based on some given criteria. +-c +-c NOTE: call this even in the case of user specified shifts in order +-c to sort the eigenvalues, and error bounds of H for later use. +-c +-c\Usage: +-c call sngets +-c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) +-c +-c\Arguments +-c ISHIFT Integer. (INPUT) +-c Method for selecting the implicit shifts at each iteration. +-c ISHIFT = 0: user specified shifts +-c ISHIFT = 1: exact shift with respect to the matrix H. +-c +-c WHICH Character*2. (INPUT) +-c Shift selection criteria. +-c 'LM' -> want the KEV eigenvalues of largest magnitude. +-c 'SM' -> want the KEV eigenvalues of smallest magnitude. +-c 'LR' -> want the KEV eigenvalues of largest real part. +-c 'SR' -> want the KEV eigenvalues of smallest real part. +-c 'LI' -> want the KEV eigenvalues of largest imaginary part. +-c 'SI' -> want the KEV eigenvalues of smallest imaginary part. +-c +-c KEV Integer. (INPUT/OUTPUT) +-c INPUT: KEV+NP is the size of the matrix H. +-c OUTPUT: Possibly increases KEV by one to keep complex conjugate +-c pairs together. +-c +-c NP Integer. (INPUT/OUTPUT) +-c Number of implicit shifts to be computed. +-c OUTPUT: Possibly decreases NP by one to keep complex conjugate +-c pairs together. +-c +-c RITZR, Real array of length KEV+NP. (INPUT/OUTPUT) +-c RITZI On INPUT, RITZR and RITZI contain the real and imaginary +-c parts of the eigenvalues of H. +-c On OUTPUT, RITZR and RITZI are sorted so that the unwanted +-c eigenvalues are in the first NP locations and the wanted +-c portion is in the last KEV locations. When exact shifts are +-c selected, the unwanted part corresponds to the shifts to +-c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues +-c are further sorted so that the ones with largest Ritz values +-c are first. +-c +-c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) +-c Error bounds corresponding to the ordering in RITZ. +-c +-c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** +-c +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c ssortc ARPACK sorting routine. +-c scopy Level 1 BLAS that copies one vector to another . +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c 1. xxxx +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine sngets ( ishift, which, kev, np, ritzr, ritzi, bounds, +- & shiftr, shifti ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- integer ishift, kev, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), +- & shiftr(1), shifti(1) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0, zero = 0.0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy, ssortc, arscnd +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mngets +-c +-c %----------------------------------------------------% +-c | LM, SM, LR, SR, LI, SI case. | +-c | Sort the eigenvalues of H into the desired order | +-c | and apply the resulting order to BOUNDS. | +-c | The eigenvalues are sorted so that the wanted part | +-c | are always in the last KEV locations. | +-c | We first do a pre-processing sort in order to keep | +-c | complex conjugate pairs together | +-c %----------------------------------------------------% +-c +- if (which .eq. 'LM') then +- call ssortc ('LR', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'SM') then +- call ssortc ('SR', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'LR') then +- call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'SR') then +- call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'LI') then +- call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) +- else if (which .eq. 'SI') then +- call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) +- end if +-c +- call ssortc (which, .true., kev+np, ritzr, ritzi, bounds) +-c +-c %-------------------------------------------------------% +-c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | +-c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | +-c | Accordingly decrease NP by one. In other words keep | +-c | complex conjugate pairs together. | +-c %-------------------------------------------------------% +-c +- if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero +- & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then +- np = np - 1 +- kev = kev + 1 +- end if +-c +- if ( ishift .eq. 1 ) then +-c +-c %-------------------------------------------------------% +-c | Sort the unwanted Ritz values used as shifts so that | +-c | the ones with largest Ritz estimates are first | +-c | This will tend to minimize the effects of the | +-c | forward instability of the iteration when they shifts | +-c | are applied in subroutine snapps. | +-c | Be careful and use 'SR' since we want to sort BOUNDS! | +-c %-------------------------------------------------------% +-c +- call ssortc ( 'SR', .true., np, bounds, ritzr, ritzi ) +- end if +-c +- call arscnd (t1) +- tngets = tngets + (t1 - t0) +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [kev], ndigit, '_ngets: KEV is') +- call ivout (logfil, 1, [np], ndigit, '_ngets: NP is') +- call svout (logfil, kev+np, ritzr, ndigit, +- & '_ngets: Eigenvalues of current H matrix -- real part') +- call svout (logfil, kev+np, ritzi, ndigit, +- & '_ngets: Eigenvalues of current H matrix -- imag part') +- call svout (logfil, kev+np, bounds, ndigit, +- & '_ngets: Ritz estimates of the current KEV+NP Ritz values') +- end if +-c +- return +-c +-c %---------------% +-c | End of sngets | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaitr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaitr.f +deleted file mode 100644 +index a5df2c2ec7..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaitr.f ++++ /dev/null +@@ -1,853 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssaitr +-c +-c\Description: +-c Reverse communication interface for applying NP additional steps to +-c a K step symmetric Arnoldi factorization. +-c +-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +-c +-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +-c +-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +-c +-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +-c +-c where OP and B are as in ssaupd. The B-norm of r_{k+p} is also +-c computed and returned. +-c +-c\Usage: +-c call ssaitr +-c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c This is for the restart phase to force the new +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y, +-c IPNTR(3) is the pointer into WORK for B * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c When the routine is used in the "shift-and-invert" mode, the +-c vector B * Q is already available and does not need to be +-c recomputed in forming OP * Q. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of matrix B that defines the +-c semi-inner product for the operator OP. See ssaupd. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c K Integer. (INPUT) +-c Current order of H and the number of columns of V. +-c +-c NP Integer. (INPUT) +-c Number of additional Arnoldi steps to take. +-c +-c MODE Integer. (INPUT) +-c Signifies which form for "OP". If MODE=2 then +-c a reduction in the number of B matrix vector multiplies +-c is possible since the B-norm of OP*x is equivalent to +-c the inv(B)-norm of A*x. +-c +-c RESID Real array of length N. (INPUT/OUTPUT) +-c On INPUT: RESID contains the residual vector r_{k}. +-c On OUTPUT: RESID contains the residual vector r_{k+p}. +-c +-c RNORM Real scalar. (INPUT/OUTPUT) +-c On INPUT the B-norm of r_{k}. +-c On OUTPUT the B-norm of the updated residual r_{k+p}. +-c +-c V Real N by K+NP array. (INPUT/OUTPUT) +-c On INPUT: V contains the Arnoldi vectors in the first K +-c columns. +-c On OUTPUT: V contains the new NP Arnoldi vectors in the next +-c NP columns. The first K columns are unchanged. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Real (K+NP) by 2 array. (INPUT/OUTPUT) +-c H is used to store the generated symmetric tridiagonal matrix +-c with the subdiagonal in the first column starting at H(2,1) +-c and the main diagonal in the second column. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORK for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The calling program should not +-c use WORKD as temporary workspace during the iteration !!!!!! +-c On INPUT, WORKD(1:N) = B*RESID where RESID is associated +-c with the K step Arnoldi factorization. Used to save some +-c computation at the first step. +-c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated +-c with the K+NP step Arnoldi factorization. +-c +-c INFO Integer. (OUTPUT) +-c = 0: Normal exit. +-c > 0: Size of an invariant subspace of OP is found that is +-c less than K + NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c sgetv0 ARPACK routine to generate the initial vector. +-c ivout ARPACK utility routine that prints integers. +-c smout ARPACK utility routine that prints matrices. +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c slascl LAPACK routine for careful scaling of a matrix. +-c sgemv Level 2 BLAS routine for matrix vector multiplication. +-c saxpy Level 1 BLAS that computes a vector triad. +-c sscal Level 1 BLAS that scales a vector. +-c scopy Level 1 BLAS that copies one vector to another . +-c sdot Level 1 BLAS that computes the scalar product of two vectors. +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/93: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 +-c +-c\Remarks +-c The algorithm implemented is: +-c +-c restart = .false. +-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +-c r_{k} contains the initial residual vector even for k = 0; +-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +-c computed by the calling program. +-c +-c betaj = rnorm ; p_{k+1} = B*r_{k} ; +-c For j = k+1, ..., k+np Do +-c 1) if ( betaj < tol ) stop or restart depending on j. +-c if ( restart ) generate a new starting vector. +-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +-c p_{j} = p_{j}/betaj +-c 3) r_{j} = OP*v_{j} where OP is defined as in ssaupd +-c For shift-invert mode p_{j} = B*v_{j} is already available. +-c wnorm = || OP*v_{j} || +-c 4) Compute the j-th step residual vector. +-c w_{j} = V_{j}^T * B * OP * v_{j} +-c r_{j} = OP*v_{j} - V_{j} * w_{j} +-c alphaj <- j-th component of w_{j} +-c rnorm = || r_{j} || +-c betaj+1 = rnorm +-c If (rnorm > 0.717*wnorm) accept step and go back to 1) +-c 5) Re-orthogonalization step: +-c s = V_{j}'*B*r_{j} +-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +-c alphaj = alphaj + s_{j}; +-c 6) Iterative refinement step: +-c If (rnorm1 > 0.717*rnorm) then +-c rnorm = rnorm1 +-c accept step and go back to 1) +-c Else +-c rnorm = rnorm1 +-c If this is the first time in step 6), go to 5) +-c Else r_{j} lies in the span of V_{j} numerically. +-c Set r_{j} = 0 and rnorm = 0; go to 1) +-c EndIf +-c End Do +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssaitr +- & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, +- & ipntr, workd, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- integer ido, info, k, ldh, ldv, n, mode, np +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Real +- & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical first, orth1, orth2, rstart, step3, step4 +- integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, +- & infol, jj +- Real +- & rnorm1, wnorm, safmin, temp1 +- save orth1, orth2, rstart, step3, step4, +- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, +- & rnorm1, safmin, wnorm +-c +-c %-----------------------% +-c | Local Array Arguments | +-c %-----------------------% +-c +- Real +- & xtemp(2) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external saxpy, scopy, sscal, sgemv, sgetv0, svout, smout, +- & slascl, ivout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & sdot, snrm2, slamch +- external sdot, snrm2, slamch +-c +-c %-----------------% +-c | Data statements | +-c %-----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +- first = .false. +-c +-c %--------------------------------% +-c | safmin = safe minimum is such | +-c | that 1/sfmin does not overflow | +-c %--------------------------------% +-c +- safmin = slamch('safmin') +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msaitr +-c +-c %------------------------------% +-c | Initial call to this routine | +-c %------------------------------% +-c +- info = 0 +- step3 = .false. +- step4 = .false. +- rstart = .false. +- orth1 = .false. +- orth2 = .false. +-c +-c %--------------------------------% +-c | Pointer to the current step of | +-c | the factorization to build | +-c %--------------------------------% +-c +- j = k + 1 +-c +-c %------------------------------------------% +-c | Pointers used for reverse communication | +-c | when using WORKD. | +-c %------------------------------------------% +-c +- ipj = 1 +- irj = ipj + n +- ivj = irj + n +- end if +-c +-c %-------------------------------------------------% +-c | When in reverse communication mode one of: | +-c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +-c | will be .true. | +-c | STEP3: return from computing OP*v_{j}. | +-c | STEP4: return from computing B-norm of OP*v_{j} | +-c | ORTH1: return from computing B-norm of r_{j+1} | +-c | ORTH2: return from computing B-norm of | +-c | correction to the residual vector. | +-c | RSTART: return from OP computations needed by | +-c | sgetv0. | +-c %-------------------------------------------------% +-c +- if (step3) go to 50 +- if (step4) go to 60 +- if (orth1) go to 70 +- if (orth2) go to 90 +- if (rstart) go to 30 +-c +-c %------------------------------% +-c | Else this is the first step. | +-c %------------------------------% +-c +-c %--------------------------------------------------------------% +-c | | +-c | A R N O L D I I T E R A T I O N L O O P | +-c | | +-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [j], ndigit, +- & '_saitr: generating Arnoldi vector no.') +- call svout (logfil, 1, [rnorm], ndigit, +- & '_saitr: B-norm of the current residual =') +- end if +-c +-c %---------------------------------------------------------% +-c | Check for exact zero. Equivalent to determining whether | +-c | a j-step Arnoldi factorization is present. | +-c %---------------------------------------------------------% +-c +- if (rnorm .gt. zero) go to 40 +-c +-c %---------------------------------------------------% +-c | Invariant subspace found, generate a new starting | +-c | vector which is orthogonal to the current Arnoldi | +-c | basis and continue the iteration. | +-c %---------------------------------------------------% +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_saitr: ****** restart at step ******') +- end if +-c +-c %---------------------------------------------% +-c | ITRY is the loop variable that controls the | +-c | maximum amount of times that a restart is | +-c | attempted. NRSTRT is used by stat.h | +-c %---------------------------------------------% +-c +- nrstrt = nrstrt + 1 +- itry = 1 +- 20 continue +- rstart = .true. +- ido = 0 +- 30 continue +-c +-c %--------------------------------------% +-c | If in reverse communication mode and | +-c | RSTART = .true. flow returns here. | +-c %--------------------------------------% +-c +- call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, +- & resid, rnorm, ipntr, workd, ierr) +- if (ido .ne. 99) go to 9000 +- if (ierr .lt. 0) then +- itry = itry + 1 +- if (itry .le. 3) go to 20 +-c +-c %------------------------------------------------% +-c | Give up after several restart attempts. | +-c | Set INFO to the size of the invariant subspace | +-c | which spans OP and exit. | +-c %------------------------------------------------% +-c +- info = j - 1 +- call arscnd (t1) +- tsaitr = tsaitr + (t1 - t0) +- ido = 99 +- go to 9000 +- end if +-c +- 40 continue +-c +-c %---------------------------------------------------------% +-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +-c | when reciprocating a small RNORM, test against lower | +-c | machine bound. | +-c %---------------------------------------------------------% +-c +- call scopy (n, resid, 1, v(1,j), 1) +- if (rnorm .ge. safmin) then +- temp1 = one / rnorm +- call sscal (n, temp1, v(1,j), 1) +- call sscal (n, temp1, workd(ipj), 1) +- else +-c +-c %-----------------------------------------% +-c | To scale both v_{j} and p_{j} carefully | +-c | use LAPACK routine SLASCL | +-c %-----------------------------------------% +-c +- call slascl ('General', i, i, rnorm, one, n, 1, +- & v(1,j), n, infol) +- call slascl ('General', i, i, rnorm, one, n, 1, +- & workd(ipj), n, infol) +- end if +-c +-c %------------------------------------------------------% +-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +-c | Note that this is not quite yet r_{j}. See STEP 4 | +-c %------------------------------------------------------% +-c +- step3 = .true. +- nopx = nopx + 1 +- call arscnd (t2) +- call scopy (n, v(1,j), 1, workd(ivj), 1) +- ipntr(1) = ivj +- ipntr(2) = irj +- ipntr(3) = ipj +- ido = 1 +-c +-c %-----------------------------------% +-c | Exit in order to compute OP*v_{j} | +-c %-----------------------------------% +-c +- go to 9000 +- 50 continue +-c +-c %-----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | +-c %-----------------------------------% +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +-c +- step3 = .false. +-c +-c %------------------------------------------% +-c | Put another copy of OP*v_{j} into RESID. | +-c %------------------------------------------% +-c +- call scopy (n, workd(irj), 1, resid, 1) +-c +-c %-------------------------------------------% +-c | STEP 4: Finish extending the symmetric | +-c | Arnoldi to length j. If MODE = 2 | +-c | then B*OP = B*inv(B)*A = A and | +-c | we don't need to compute B*OP. | +-c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | +-c | assumed to have A*v_{j}. | +-c %-------------------------------------------% +-c +- if (mode .eq. 2) go to 65 +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- step4 = .true. +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-------------------------------------% +-c | Exit in order to compute B*OP*v_{j} | +-c %-------------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy(n, resid, 1 , workd(ipj), 1) +- end if +- 60 continue +-c +-c %-----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | +-c %-----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- step4 = .false. +-c +-c %-------------------------------------% +-c | The following is needed for STEP 5. | +-c | Compute the B-norm of OP*v_{j}. | +-c %-------------------------------------% +-c +- 65 continue +- if (mode .eq. 2) then +-c +-c %----------------------------------% +-c | Note that the B-norm of OP*v_{j} | +-c | is the inv(B)-norm of A*v_{j}. | +-c %----------------------------------% +-c +- wnorm = sdot (n, resid, 1, workd(ivj), 1) +- wnorm = sqrt(abs(wnorm)) +- else if (bmat .eq. 'G') then +- wnorm = sdot (n, resid, 1, workd(ipj), 1) +- wnorm = sqrt(abs(wnorm)) +- else if (bmat .eq. 'I') then +- wnorm = snrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------% +-c | Compute the j-th residual corresponding | +-c | to the j step factorization. | +-c | Use Classical Gram Schmidt and compute: | +-c | w_{j} <- V_{j}^T * B * OP * v_{j} | +-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +-c %-----------------------------------------% +-c +-c +-c %------------------------------------------% +-c | Compute the j Fourier coefficients w_{j} | +-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +-c %------------------------------------------% +-c +- if (mode .ne. 2 ) then +- call sgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, +- & workd(irj), 1) +- else if (mode .eq. 2) then +- call sgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, +- & workd(irj), 1) +- end if +-c +-c %--------------------------------------% +-c | Orthgonalize r_{j} against V_{j}. | +-c | RESID contains OP*v_{j}. See STEP 3. | +-c %--------------------------------------% +-c +- call sgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, +- & resid, 1) +-c +-c %--------------------------------------% +-c | Extend H to have j rows and columns. | +-c %--------------------------------------% +-c +- h(j,2) = workd(irj + j - 1) +- if (j .eq. 1 .or. rstart) then +- h(j,1) = zero +- else +- h(j,1) = rnorm +- end if +- call arscnd (t4) +-c +- orth1 = .true. +- iter = 0 +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*r_{j} | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd(ipj), 1) +- end if +- 70 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH1 = .true. | +-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- orth1 = .false. +-c +-c %------------------------------% +-c | Compute the B-norm of r_{j}. | +-c %------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm = sdot (n, resid, 1, workd(ipj), 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = snrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------------------------% +-c | STEP 5: Re-orthogonalization / Iterative refinement phase | +-c | Maximum NITER_ITREF tries. | +-c | | +-c | s = V_{j}^T * B * r_{j} | +-c | r_{j} = r_{j} - V_{j}*s | +-c | alphaj = alphaj + s_{j} | +-c | | +-c | The stopping criteria used for iterative refinement is | +-c | discussed in Parlett's book SEP, page 107 and in Gragg & | +-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +-c | Determine if we need to correct the residual. The goal is | +-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +-c %-----------------------------------------------------------% +-c +- if (rnorm .gt. 0.717*wnorm) go to 100 +- nrorth = nrorth + 1 +-c +-c %---------------------------------------------------% +-c | Enter the Iterative refinement phase. If further | +-c | refinement is necessary, loop back here. The loop | +-c | variable is ITER. Perform a step of Classical | +-c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +-c %---------------------------------------------------% +-c +- 80 continue +-c +- if (msglvl .gt. 2) then +- xtemp(1) = wnorm +- xtemp(2) = rnorm +- call svout (logfil, 2, xtemp, ndigit, +- & '_saitr: re-orthonalization ; wnorm and rnorm are') +- end if +-c +-c %----------------------------------------------------% +-c | Compute V_{j}^T * B * r_{j}. | +-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +-c %----------------------------------------------------% +-c +- call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, +- & zero, workd(irj), 1) +-c +-c %----------------------------------------------% +-c | Compute the correction to the residual: | +-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +-c | The correction to H is v(:,1:J)*H(1:J,1:J) + | +-c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | +-c | H(j,j) is updated. | +-c %----------------------------------------------% +-c +- call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, +- & one, resid, 1) +-c +- if (j .eq. 1 .or. rstart) h(j,1) = zero +- h(j,2) = h(j,2) + workd(irj + j - 1) +-c +- orth2 = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-----------------------------------% +-c | Exit in order to compute B*r_{j}. | +-c | r_{j} is the corrected residual. | +-c %-----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd(ipj), 1) +- end if +- 90 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH2 = .true. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +-c %-----------------------------------------------------% +-c | Compute the B-norm of the corrected residual r_{j}. | +-c %-----------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- rnorm1 = sdot (n, resid, 1, workd(ipj), 1) +- rnorm1 = sqrt(abs(rnorm1)) +- else if (bmat .eq. 'I') then +- rnorm1 = snrm2(n, resid, 1) +- end if +-c +- if (msglvl .gt. 0 .and. iter .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_saitr: Iterative refinement for Arnoldi residual') +- if (msglvl .gt. 2) then +- xtemp(1) = rnorm +- xtemp(2) = rnorm1 +- call svout (logfil, 2, xtemp, ndigit, +- & '_saitr: iterative refinement ; rnorm and rnorm1 are') +- end if +- end if +-c +-c %-----------------------------------------% +-c | Determine if we need to perform another | +-c | step of re-orthogonalization. | +-c %-----------------------------------------% +-c +- if (rnorm1 .gt. 0.717*rnorm) then +-c +-c %--------------------------------% +-c | No need for further refinement | +-c %--------------------------------% +-c +- rnorm = rnorm1 +-c +- else +-c +-c %-------------------------------------------% +-c | Another step of iterative refinement step | +-c | is required. NITREF is used by stat.h | +-c %-------------------------------------------% +-c +- nitref = nitref + 1 +- rnorm = rnorm1 +- iter = iter + 1 +- if (iter .le. 1) go to 80 +-c +-c %-------------------------------------------------% +-c | Otherwise RESID is numerically in the span of V | +-c %-------------------------------------------------% +-c +- do 95 jj = 1, n +- resid(jj) = zero +- 95 continue +- rnorm = zero +- end if +-c +-c %----------------------------------------------% +-c | Branch here directly if iterative refinement | +-c | wasn't necessary or after at most NITER_REF | +-c | steps of iterative refinement. | +-c %----------------------------------------------% +-c +- 100 continue +-c +- rstart = .false. +- orth2 = .false. +-c +- call arscnd (t5) +- titref = titref + (t5 - t4) +-c +-c %----------------------------------------------------------% +-c | Make sure the last off-diagonal element is non negative | +-c | If not perform a similarity transformation on H(1:j,1:j) | +-c | and scale v(:,j) by -1. | +-c %----------------------------------------------------------% +-c +- if (h(j,1) .lt. zero) then +- h(j,1) = -h(j,1) +- if ( j .lt. k+np) then +- call sscal(n, -one, v(1,j+1), 1) +- else +- call sscal(n, -one, resid, 1) +- end if +- end if +-c +-c %------------------------------------% +-c | STEP 6: Update j = j+1; Continue | +-c %------------------------------------% +-c +- j = j + 1 +- if (j .gt. k+np) then +- call arscnd (t1) +- tsaitr = tsaitr + (t1 - t0) +- ido = 99 +-c +- if (msglvl .gt. 1) then +- call svout (logfil, k+np, h(1,2), ndigit, +- & '_saitr: main diagonal of matrix H of step K+NP.') +- if (k+np .gt. 1) then +- call svout (logfil, k+np-1, h(2,1), ndigit, +- & '_saitr: sub diagonal of matrix H of step K+NP.') +- end if +- end if +-c +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Loop back to extend the factorization by another step. | +-c %--------------------------------------------------------% +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of ssaitr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssapps.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssapps.f +deleted file mode 100644 +index 77bd9d52c4..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssapps.f ++++ /dev/null +@@ -1,516 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssapps +-c +-c\Description: +-c Given the Arnoldi factorization +-c +-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +-c +-c apply NP shifts implicitly resulting in +-c +-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +-c +-c where Q is an orthogonal matrix of order KEV+NP. Q is the product of +-c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi +-c factorization becomes: +-c +-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +-c +-c\Usage: +-c call ssapps +-c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Problem size, i.e. dimension of matrix A. +-c +-c KEV Integer. (INPUT) +-c INPUT: KEV+NP is the size of the input matrix H. +-c OUTPUT: KEV is the size of the updated matrix HNEW. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be applied. +-c +-c SHIFT Real array of length NP. (INPUT) +-c The shifts to be applied. +-c +-c V Real N by (KEV+NP) array. (INPUT/OUTPUT) +-c INPUT: V contains the current KEV+NP Arnoldi vectors. +-c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors +-c are in the first KEV columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Real (KEV+NP) by 2 array. (INPUT/OUTPUT) +-c INPUT: H contains the symmetric tridiagonal matrix of the +-c Arnoldi factorization with the subdiagonal in the 1st column +-c starting at H(2,1) and the main diagonal in the 2nd column. +-c OUTPUT: H contains the updated tridiagonal matrix in the +-c KEV leading submatrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RESID Real array of length (N). (INPUT/OUTPUT) +-c INPUT: RESID contains the the residual vector r_{k+p}. +-c OUTPUT: RESID is the updated residual vector rnew_{k}. +-c +-c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) +-c Work array used to accumulate the rotations during the bulge +-c chase sweep. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKD Real work array of length 2*N. (WORKSPACE) +-c Distributed array used in the application of the accumulated +-c orthogonal matrix Q. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c slartg LAPACK Givens rotation construction routine. +-c slacpy LAPACK matrix copy routine. +-c slaset LAPACK matrix initialization routine. +-c sgemv Level 2 BLAS routine for matrix vector multiplication. +-c saxpy Level 1 BLAS that computes a vector triad. +-c scopy Level 1 BLAS that copies one vector to another. +-c sscal Level 1 BLAS that scales a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/16/93: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 +-c +-c\Remarks +-c 1. In this version, each shift is applied to all the subblocks of +-c the tridiagonal matrix H and not just to the submatrix that it +-c comes from. This routine assumes that the subdiagonal elements +-c of H that are stored in h(1:kev+np,1) are nonegative upon input +-c and enforce this condition upon output. This version incorporates +-c deflation. See code for documentation. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssapps +- & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer kev, ldh, ldq, ldv, n, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), +- & v(ldv,kev+np), workd(2*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, iend, istart, itop, j, jj, kplusp, msglvl +- logical first +- Real +- & a1, a2, a3, a4, big, c, epsmch, f, g, r, s +- save epsmch, first +-c +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external saxpy, scopy, sscal, slacpy, slartg, slaset, svout, +- & ivout, arscnd, sgemv +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slamch +- external slamch +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs +-c +-c %----------------% +-c | Data statements | +-c %----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +- epsmch = slamch('Epsilon-Machine') +- first = .false. +- end if +- itop = 1 +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msapps +-c +- kplusp = kev + np +-c +-c %----------------------------------------------% +-c | Initialize Q to the identity matrix of order | +-c | kplusp used to accumulate the rotations. | +-c %----------------------------------------------% +-c +- call slaset ('All', kplusp, kplusp, zero, one, q, ldq) +-c +-c %----------------------------------------------% +-c | Quick return if there are no shifts to apply | +-c %----------------------------------------------% +-c +- if (np .eq. 0) go to 9000 +-c +-c %----------------------------------------------------------% +-c | Apply the np shifts implicitly. Apply each shift to the | +-c | whole matrix and not just to the submatrix from which it | +-c | comes. | +-c %----------------------------------------------------------% +-c +- do 90 jj = 1, np +-c +- istart = itop +-c +-c %----------------------------------------------------------% +-c | Check for splitting and deflation. Currently we consider | +-c | an off-diagonal element h(i+1,1) negligible if | +-c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | +-c | for i=1:KEV+NP-1. | +-c | If above condition tests true then we set h(i+1,1) = 0. | +-c | Note that h(1:KEV+NP,1) are assumed to be non negative. | +-c %----------------------------------------------------------% +-c +- 20 continue +-c +-c %------------------------------------------------% +-c | The following loop exits early if we encounter | +-c | a negligible off diagonal element. | +-c %------------------------------------------------% +-c +- do 30 i = istart, kplusp-1 +- big = abs(h(i,2)) + abs(h(i+1,2)) +- if (h(i+1,1) .le. epsmch*big) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_sapps: deflation at row/column no.') +- call ivout (logfil, 1, [jj], ndigit, +- & '_sapps: occurred before shift number.') +- call svout (logfil, 1, h(i+1,1), ndigit, +- & '_sapps: the corresponding off diagonal element') +- end if +- h(i+1,1) = zero +- iend = i +- go to 40 +- end if +- 30 continue +- iend = kplusp +- 40 continue +-c +- if (istart .lt. iend) then +-c +-c %--------------------------------------------------------% +-c | Construct the plane rotation G'(istart,istart+1,theta) | +-c | that attempts to drive h(istart+1,1) to zero. | +-c %--------------------------------------------------------% +-c +- f = h(istart,2) - shift(jj) +- g = h(istart+1,1) +- call slartg (f, g, c, s, r) +-c +-c %-------------------------------------------------------% +-c | Apply rotation to the left and right of H; | +-c | H <- G' * H * G, where G = G(istart,istart+1,theta). | +-c | This will create a "bulge". | +-c %-------------------------------------------------------% +-c +- a1 = c*h(istart,2) + s*h(istart+1,1) +- a2 = c*h(istart+1,1) + s*h(istart+1,2) +- a4 = c*h(istart+1,2) - s*h(istart+1,1) +- a3 = c*h(istart+1,1) - s*h(istart,2) +- h(istart,2) = c*a1 + s*a2 +- h(istart+1,2) = c*a4 - s*a3 +- h(istart+1,1) = c*a3 + s*a4 +-c +-c %----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G | +-c %----------------------------------------------------% +-c +- do 60 j = 1, min(istart+jj,kplusp) +- a1 = c*q(j,istart) + s*q(j,istart+1) +- q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) +- q(j,istart) = a1 +- 60 continue +-c +-c +-c %----------------------------------------------% +-c | The following loop chases the bulge created. | +-c | Note that the previous rotation may also be | +-c | done within the following loop. But it is | +-c | kept separate to make the distinction among | +-c | the bulge chasing sweeps and the first plane | +-c | rotation designed to drive h(istart+1,1) to | +-c | zero. | +-c %----------------------------------------------% +-c +- do 70 i = istart+1, iend-1 +-c +-c %----------------------------------------------% +-c | Construct the plane rotation G'(i,i+1,theta) | +-c | that zeros the i-th bulge that was created | +-c | by G(i-1,i,theta). g represents the bulge. | +-c %----------------------------------------------% +-c +- f = h(i,1) +- g = s*h(i+1,1) +-c +-c %----------------------------------% +-c | Final update with G(i-1,i,theta) | +-c %----------------------------------% +-c +- h(i+1,1) = c*h(i+1,1) +- call slartg (f, g, c, s, r) +-c +-c %-------------------------------------------% +-c | The following ensures that h(1:iend-1,1), | +-c | the first iend-2 off diagonal of elements | +-c | H, remain non negative. | +-c %-------------------------------------------% +-c +- if (r .lt. zero) then +- r = -r +- c = -c +- s = -s +- end if +-c +-c %--------------------------------------------% +-c | Apply rotation to the left and right of H; | +-c | H <- G * H * G', where G = G(i,i+1,theta) | +-c %--------------------------------------------% +-c +- h(i,1) = r +-c +- a1 = c*h(i,2) + s*h(i+1,1) +- a2 = c*h(i+1,1) + s*h(i+1,2) +- a3 = c*h(i+1,1) - s*h(i,2) +- a4 = c*h(i+1,2) - s*h(i+1,1) +-c +- h(i,2) = c*a1 + s*a2 +- h(i+1,2) = c*a4 - s*a3 +- h(i+1,1) = c*a3 + s*a4 +-c +-c %----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G | +-c %----------------------------------------------------% +-c +- do 50 j = 1, min( i+jj, kplusp ) +- a1 = c*q(j,i) + s*q(j,i+1) +- q(j,i+1) = - s*q(j,i) + c*q(j,i+1) +- q(j,i) = a1 +- 50 continue +-c +- 70 continue +-c +- end if +-c +-c %--------------------------% +-c | Update the block pointer | +-c %--------------------------% +-c +- istart = iend + 1 +-c +-c %------------------------------------------% +-c | Make sure that h(iend,1) is non-negative | +-c | If not then set h(iend,1) <-- -h(iend,1) | +-c | and negate the last column of Q. | +-c | We have effectively carried out a | +-c | similarity on transformation H | +-c %------------------------------------------% +-c +- if (h(iend,1) .lt. zero) then +- h(iend,1) = -h(iend,1) +- call sscal(kplusp, -one, q(1,iend), 1) +- end if +-c +-c %--------------------------------------------------------% +-c | Apply the same shift to the next block if there is any | +-c %--------------------------------------------------------% +-c +- if (iend .lt. kplusp) go to 20 +-c +-c %-----------------------------------------------------% +-c | Check if we can increase the the start of the block | +-c %-----------------------------------------------------% +-c +- do 80 i = itop, kplusp-1 +- if (h(i+1,1) .gt. zero) go to 90 +- itop = itop + 1 +- 80 continue +-c +-c %-----------------------------------% +-c | Finished applying the jj-th shift | +-c %-----------------------------------% +-c +- 90 continue +-c +-c %------------------------------------------% +-c | All shifts have been applied. Check for | +-c | more possible deflation that might occur | +-c | after the last shift is applied. | +-c %------------------------------------------% +-c +- do 100 i = itop, kplusp-1 +- big = abs(h(i,2)) + abs(h(i+1,2)) +- if (h(i+1,1) .le. epsmch*big) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_sapps: deflation at row/column no.') +- call svout (logfil, 1, h(i+1,1), ndigit, +- & '_sapps: the corresponding off diagonal element') +- end if +- h(i+1,1) = zero +- end if +- 100 continue +-c +-c %-------------------------------------------------% +-c | Compute the (kev+1)-st column of (V*Q) and | +-c | temporarily store the result in WORKD(N+1:2*N). | +-c | This is not necessary if h(kev+1,1) = 0. | +-c %-------------------------------------------------% +-c +- if ( h(kev+1,1) .gt. zero ) +- & call sgemv ('N', n, kplusp, one, v, ldv, +- & q(1,kev+1), 1, zero, workd(n+1), 1) +-c +-c %-------------------------------------------------------% +-c | Compute column 1 to kev of (V*Q) in backward order | +-c | taking advantage that Q is an upper triangular matrix | +-c | with lower bandwidth np. | +-c | Place results in v(:,kplusp-kev:kplusp) temporarily. | +-c %-------------------------------------------------------% +-c +- do 130 i = 1, kev +- call sgemv ('N', n, kplusp-i+1, one, v, ldv, +- & q(1,kev-i+1), 1, zero, workd, 1) +- call scopy (n, workd, 1, v(1,kplusp-i+1), 1) +- 130 continue +-c +-c %-------------------------------------------------% +-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +-c %-------------------------------------------------% +-c +- call slacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) +-c +-c %--------------------------------------------% +-c | Copy the (kev+1)-st column of (V*Q) in the | +-c | appropriate place if h(kev+1,1) .ne. zero. | +-c %--------------------------------------------% +-c +- if ( h(kev+1,1) .gt. zero ) +- & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) +-c +-c %-------------------------------------% +-c | Update the residual vector: | +-c | r <- sigmak*r + betak*v(:,kev+1) | +-c | where | +-c | sigmak = (e_{kev+p}'*Q)*e_{kev} | +-c | betak = e_{kev+1}'*H*e_{kev} | +-c %-------------------------------------% +-c +- call sscal (n, q(kplusp,kev), resid, 1) +- if (h(kev+1,1) .gt. zero) +- & call saxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) +-c +- if (msglvl .gt. 1) then +- call svout (logfil, 1, q(kplusp,kev), ndigit, +- & '_sapps: sigmak of the updated residual vector') +- call svout (logfil, 1, h(kev+1,1), ndigit, +- & '_sapps: betak of the updated residual vector') +- call svout (logfil, kev, h(1,2), ndigit, +- & '_sapps: updated main diagonal of H for next iteration') +- if (kev .gt. 1) then +- call svout (logfil, kev-1, h(2,1), ndigit, +- & '_sapps: updated sub diagonal of H for next iteration') +- end if +- end if +-c +- call arscnd (t1) +- tsapps = tsapps + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of ssapps | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaup2.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaup2.f +deleted file mode 100644 +index 504f28fb00..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaup2.f ++++ /dev/null +@@ -1,850 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssaup2 +-c +-c\Description: +-c Intermediate level interface called by ssaupd. +-c +-c\Usage: +-c call ssaup2 +-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +-c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c +-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in ssaupd. +-c MODE, ISHIFT, MXITER: see the definition of IPARAM in ssaupd. +-c +-c NP Integer. (INPUT/OUTPUT) +-c Contains the number of implicit shifts to apply during +-c each Arnoldi/Lanczos iteration. +-c If ISHIFT=1, NP is adjusted dynamically at each iteration +-c to accelerate convergence and prevent stagnation. +-c This is also roughly equal to the number of matrix-vector +-c products (involving the operator OP) per Arnoldi iteration. +-c The logic for adjusting is contained within the current +-c subroutine. +-c If ISHIFT=0, NP is the number of shifts the user needs +-c to provide via reverse communication. 0 < NP < NCV-NEV. +-c NP may be less than NCV-NEV since a leading block of the current +-c upper Tridiagonal matrix has split off and contains "unwanted" +-c Ritz values. +-c Upon termination of the IRA iteration, NP contains the number +-c of "converged" wanted Ritz values. +-c +-c IUPD Integer. (INPUT) +-c IUPD .EQ. 0: use explicit restart instead implicit update. +-c IUPD .NE. 0: use implicit update. +-c +-c V Real N by (NEV+NP) array. (INPUT/OUTPUT) +-c The Lanczos basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Real (NEV+NP) by 2 array. (OUTPUT) +-c H is used to store the generated symmetric tridiagonal matrix +-c The subdiagonal is stored in the first column of H starting +-c at H(2,1). The main diagonal is stored in the second column +-c of H starting at H(1,2). If ssaup2 converges store the +-c B-norm of the final residual vector in H(1,1). +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZ Real array of length NEV+NP. (OUTPUT) +-c RITZ(1:NEV) contains the computed Ritz values of OP. +-c +-c BOUNDS Real array of length NEV+NP. (OUTPUT) +-c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. +-c +-c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) +-c Private (replicated) work array used to accumulate the +-c rotation in the shift application step. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Real array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. It is used in the computation of the +-c tridiagonal eigenvalue problem, the calculation and +-c application of the shifts and convergence checking. +-c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations +-c of WORKL are used in reverse communication to hold the user +-c supplied shifts. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD for +-c vectors used by the Lanczos iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in one of +-c the spectral transformation modes. X is the current +-c operand. +-c ------------------------------------------------------------- +-c +-c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Lanczos iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note in ssaupd. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal return. +-c = 1: All possible eigenvalues of OP has been found. +-c NP returns the size of the invariant subspace +-c spanning the operator OP. +-c = 2: No shifts could be applied. +-c = -8: Error return from trid. eigenvalue calculation; +-c This should never happen. +-c = -9: Starting vector is zero. +-c = -9999: Could not build an Lanczos factorization. +-c Size that was built in returned in NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +-c 1980. +-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +-c Computer Physics Communications, 53 (1989), pp 169-179. +-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +-c Implement the Spectral Transformation", Math. Comp., 48 (1987), +-c pp 663-673. +-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +-c SIAM J. Matr. Anal. Apps., January (1993). +-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +-c for Updating the QR decomposition", ACM TOMS, December 1990, +-c Volume 16 Number 4, pp 369-377. +-c +-c\Routines called: +-c sgetv0 ARPACK initial vector generation routine. +-c ssaitr ARPACK Lanczos factorization routine. +-c ssapps ARPACK application of implicit shifts routine. +-c ssconv ARPACK convergence of Ritz values routine. +-c sseigt ARPACK compute Ritz values and error bounds routine. +-c ssgets ARPACK reorder Ritz values and error bounds routine. +-c ssortr ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c scopy Level 1 BLAS that copies one vector to another. +-c sdot Level 1 BLAS that computes the scalar product of two vectors. +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c sscal Level 1 BLAS that scales a vector. +-c sswap Level 1 BLAS that swaps two vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.4' +-c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) +-c +-c\SCCS Information: @(#) +-c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssaup2 +- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, +- & q, ldq, workl, ipntr, workd, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, +- & n, mode, nev, np +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Real +- & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), +- & ritz(nev+np), v(ldv,nev+np), workd(3*n), +- & workl(3*(nev+np)) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character wprime*2 +- logical cnorm, getv0, initv, update, ushift +- integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, +- & np0, nptemp, nevd2, nevm2, kp(3) +- Real +- & rnorm, temp, eps23 +- save cnorm, getv0, initv, update, ushift, +- & iter, kplusp, msglvl, nconv, nev0, np0, +- & rnorm, eps23 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy, sgetv0, ssaitr, sscal, ssconv, sseigt, ssgets, +- & ssapps, ssortr, svout, ivout, arscnd, sswap +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & sdot, snrm2, slamch +- external sdot, snrm2, slamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic min +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msaup2 +-c +-c %---------------------------------% +-c | Set machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0/3.0E+0) +-c +-c %-------------------------------------% +-c | nev0 and np0 are integer variables | +-c | hold the initial values of NEV & NP | +-c %-------------------------------------% +-c +- nev0 = nev +- np0 = np +-c +-c %-------------------------------------% +-c | kplusp is the bound on the largest | +-c | Lanczos factorization built. | +-c | nconv is the current number of | +-c | "converged" eigenvlues. | +-c | iter is the counter on the current | +-c | iteration step. | +-c %-------------------------------------% +-c +- kplusp = nev0 + np0 +- nconv = 0 +- iter = 0 +-c +-c %--------------------------------------------% +-c | Set flags for computing the first NEV steps | +-c | of the Lanczos factorization. | +-c %--------------------------------------------% +-c +- getv0 = .true. +- update = .false. +- ushift = .false. +- cnorm = .false. +-c +- if (info .ne. 0) then +-c +-c %--------------------------------------------% +-c | User provides the initial residual vector. | +-c %--------------------------------------------% +-c +- initv = .true. +- info = 0 +- else +- initv = .false. +- end if +- end if +-c +-c %---------------------------------------------% +-c | Get a possibly random starting vector and | +-c | force it into the range of the operator OP. | +-c %---------------------------------------------% +-c +- 10 continue +-c +- if (getv0) then +- call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, +- & ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (rnorm .eq. zero) then +-c +-c %-----------------------------------------% +-c | The initial vector is zero. Error exit. | +-c %-----------------------------------------% +-c +- info = -9 +- go to 1200 +- end if +- getv0 = .false. +- ido = 0 +- end if +-c +-c %------------------------------------------------------------% +-c | Back from reverse communication: continue with update step | +-c %------------------------------------------------------------% +-c +- if (update) go to 20 +-c +-c %-------------------------------------------% +-c | Back from computing user specified shifts | +-c %-------------------------------------------% +-c +- if (ushift) go to 50 +-c +-c %-------------------------------------% +-c | Back from computing residual norm | +-c | at the end of the current iteration | +-c %-------------------------------------% +-c +- if (cnorm) go to 100 +-c +-c %----------------------------------------------------------% +-c | Compute the first NEV steps of the Lanczos factorization | +-c %----------------------------------------------------------% +-c +- call ssaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, +- & h, ldh, ipntr, workd, info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +-c +-c %-----------------------------------------------------% +-c | ssaitr was unable to build an Lanczos factorization | +-c | of length NEV0. INFO is returned with the size of | +-c | the factorization built. Exit main loop. | +-c %-----------------------------------------------------% +-c +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +-c +-c %--------------------------------------------------------------% +-c | | +-c | M A I N LANCZOS I T E R A T I O N L O O P | +-c | Each iteration implicitly restarts the Lanczos | +-c | factorization in place. | +-c | | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- iter = iter + 1 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [iter], ndigit, +- & '_saup2: **** Start of major iteration number ****') +- end if +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [nev], ndigit, +- & '_saup2: The length of the current Lanczos factorization') +- call ivout (logfil, 1, [np], ndigit, +- & '_saup2: Extend the Lanczos factorization by') +- end if +-c +-c %------------------------------------------------------------% +-c | Compute NP additional steps of the Lanczos factorization. | +-c %------------------------------------------------------------% +-c +- ido = 0 +- 20 continue +- update = .true. +-c +- call ssaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, +- & ldv, h, ldh, ipntr, workd, info) +-c +-c %---------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP and possibly B | +-c %---------------------------------------------------% +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +-c +-c %-----------------------------------------------------% +-c | ssaitr was unable to build an Lanczos factorization | +-c | of length NEV0+NP0. INFO is returned with the size | +-c | of the factorization built. Exit main loop. | +-c %-----------------------------------------------------% +-c +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +- update = .false. +-c +- if (msglvl .gt. 1) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_saup2: Current B-norm of residual for factorization') +- end if +-c +-c %--------------------------------------------------------% +-c | Compute the eigenvalues and corresponding error bounds | +-c | of the current symmetric tridiagonal matrix. | +-c %--------------------------------------------------------% +-c +- call sseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 1200 +- end if +-c +-c %----------------------------------------------------% +-c | Make a copy of eigenvalues and corresponding error | +-c | bounds obtained from _seigt. | +-c %----------------------------------------------------% +-c +- call scopy(kplusp, ritz, 1, workl(kplusp+1), 1) +- call scopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The selection is based on the requested number of | +-c | eigenvalues instead of the current NEV and NP to | +-c | prevent possible misconvergence. | +-c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | +-c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | +-c %---------------------------------------------------% +-c +- nev = nev0 +- np = np0 +- call ssgets (ishift, which, nev, np, ritz, bounds, workl) +-c +-c %-------------------% +-c | Convergence test. | +-c %-------------------% +-c +- call scopy (nev, bounds(np+1), 1, workl(np+1), 1) +- call ssconv (nev, ritz(np+1), workl(np+1), tol, nconv) +-c +- if (msglvl .gt. 2) then +- kp(1) = nev +- kp(2) = np +- kp(3) = nconv +- call ivout (logfil, 3, kp, ndigit, +- & '_saup2: NEV, NP, NCONV are') +- call svout (logfil, kplusp, ritz, ndigit, +- & '_saup2: The eigenvalues of H') +- call svout (logfil, kplusp, bounds, ndigit, +- & '_saup2: Ritz estimates of the current NCV Ritz values') +- end if +-c +-c %---------------------------------------------------------% +-c | Count the number of unwanted Ritz values that have zero | +-c | Ritz estimates. If any Ritz estimates are equal to zero | +-c | then a leading block of H of order equal to at least | +-c | the number of Ritz values with zero Ritz estimates has | +-c | split off. None of these Ritz values may be removed by | +-c | shifting. Decrease NP the number of shifts to apply. If | +-c | no shifts may be applied, then prepare to exit | +-c %---------------------------------------------------------% +-c +- nptemp = np +- do 30 j=1, nptemp +- if (bounds(j) .eq. zero) then +- np = np - 1 +- nev = nev + 1 +- end if +- 30 continue +-c +- if ( (nconv .ge. nev0) .or. +- & (iter .gt. mxiter) .or. +- & (np .eq. 0) ) then +-c +-c %------------------------------------------------% +-c | Prepare to exit. Put the converged Ritz values | +-c | and corresponding bounds in RITZ(1:NCONV) and | +-c | BOUNDS(1:NCONV) respectively. Then sort. Be | +-c | careful when NCONV > NP since we don't want to | +-c | swap overlapping locations. | +-c %------------------------------------------------% +-c +- if (which .eq. 'BE') then +-c +-c %-----------------------------------------------------% +-c | Both ends of the spectrum are requested. | +-c | Sort the eigenvalues into algebraically decreasing | +-c | order first then swap low end of the spectrum next | +-c | to high end in appropriate locations. | +-c | NOTE: when np < floor(nev/2) be careful not to swap | +-c | overlapping locations. | +-c %-----------------------------------------------------% +-c +- wprime = 'SA' +- call ssortr (wprime, .true., kplusp, ritz, bounds) +- nevd2 = nev0 / 2 +- nevm2 = nev0 - nevd2 +- if ( nev .gt. 1 ) then +- call sswap ( min(nevd2,np), ritz(nevm2+1), 1, +- & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) +- call sswap ( min(nevd2,np), bounds(nevm2+1), 1, +- & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) +- end if +-c +- else +-c +-c %--------------------------------------------------% +-c | LM, SM, LA, SA case. | +-c | Sort the eigenvalues of H into the an order that | +-c | is opposite to WHICH, and apply the resulting | +-c | order to BOUNDS. The eigenvalues are sorted so | +-c | that the wanted part are always within the first | +-c | NEV locations. | +-c %--------------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SM' +- if (which .eq. 'SM') wprime = 'LM' +- if (which .eq. 'LA') wprime = 'SA' +- if (which .eq. 'SA') wprime = 'LA' +-c +- call ssortr (wprime, .true., kplusp, ritz, bounds) +-c +- end if +-c +-c %--------------------------------------------------% +-c | Scale the Ritz estimate of each Ritz value | +-c | by 1 / max(eps23,magnitude of the Ritz value). | +-c %--------------------------------------------------% +-c +- do 35 j = 1, nev0 +- temp = max( eps23, abs(ritz(j)) ) +- bounds(j) = bounds(j)/temp +- 35 continue +-c +-c %----------------------------------------------------% +-c | Sort the Ritz values according to the scaled Ritz | +-c | estimates. This will push all the converged ones | +-c | towards the front of ritzr, ritzi, bounds | +-c | (in the case when NCONV < NEV.) | +-c %----------------------------------------------------% +-c +- wprime = 'LA' +- call ssortr(wprime, .true., nev0, bounds, ritz) +-c +-c %----------------------------------------------% +-c | Scale the Ritz estimate back to its original | +-c | value. | +-c %----------------------------------------------% +-c +- do 40 j = 1, nev0 +- temp = max( eps23, abs(ritz(j)) ) +- bounds(j) = bounds(j)*temp +- 40 continue +-c +-c %--------------------------------------------------% +-c | Sort the "converged" Ritz values again so that | +-c | the "threshold" values and their associated Ritz | +-c | estimates appear at the appropriate position in | +-c | ritz and bound. | +-c %--------------------------------------------------% +-c +- if (which .eq. 'BE') then +-c +-c %------------------------------------------------% +-c | Sort the "converged" Ritz values in increasing | +-c | order. The "threshold" values are in the | +-c | middle. | +-c %------------------------------------------------% +-c +- wprime = 'LA' +- call ssortr(wprime, .true., nconv, ritz, bounds) +-c +- else +-c +-c %----------------------------------------------% +-c | In LM, SM, LA, SA case, sort the "converged" | +-c | Ritz values according to WHICH so that the | +-c | "threshold" value appears at the front of | +-c | ritz. | +-c %----------------------------------------------% +- +- call ssortr(which, .true., nconv, ritz, bounds) +-c +- end if +-c +-c %------------------------------------------% +-c | Use h( 1,1 ) as storage to communicate | +-c | rnorm to _seupd if needed | +-c %------------------------------------------% +-c +- h(1,1) = rnorm +-c +- if (msglvl .gt. 1) then +- call svout (logfil, kplusp, ritz, ndigit, +- & '_saup2: Sorted Ritz values.') +- call svout (logfil, kplusp, bounds, ndigit, +- & '_saup2: Sorted ritz estimates.') +- end if +-c +-c %------------------------------------% +-c | Max iterations have been exceeded. | +-c %------------------------------------% +-c +- if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 +-c +-c %---------------------% +-c | No shifts to apply. | +-c %---------------------% +-c +- if (np .eq. 0 .and. nconv .lt. nev0) info = 2 +-c +- np = nconv +- go to 1100 +-c +- else if (nconv .lt. nev .and. ishift .eq. 1) then +-c +-c %---------------------------------------------------% +-c | Do not have all the requested eigenvalues yet. | +-c | To prevent possible stagnation, adjust the number | +-c | of Ritz values and the shifts. | +-c %---------------------------------------------------% +-c +- nevbef = nev +- nev = nev + min (nconv, np/2) +- if (nev .eq. 1 .and. kplusp .ge. 6) then +- nev = kplusp / 2 +- else if (nev .eq. 1 .and. kplusp .gt. 2) then +- nev = 2 +- end if +- np = kplusp - nev +-c +-c %---------------------------------------% +-c | If the size of NEV was just increased | +-c | resort the eigenvalues. | +-c %---------------------------------------% +-c +- if (nevbef .lt. nev) +- & call ssgets (ishift, which, nev, np, ritz, bounds, +- & workl) +-c +- end if +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [nconv], ndigit, +- & '_saup2: no. of "converged" Ritz values at this iter.') +- if (msglvl .gt. 1) then +- kp(1) = nev +- kp(2) = np +- call ivout (logfil, 2, kp, ndigit, +- & '_saup2: NEV and NP are') +- call svout (logfil, nev, ritz(np+1), ndigit, +- & '_saup2: "wanted" Ritz values.') +- call svout (logfil, nev, bounds(np+1), ndigit, +- & '_saup2: Ritz estimates of the "wanted" values ') +- end if +- end if +- +-c +- if (ishift .eq. 0) then +-c +-c %-----------------------------------------------------% +-c | User specified shifts: reverse communication to | +-c | compute the shifts. They are returned in the first | +-c | NP locations of WORKL. | +-c %-----------------------------------------------------% +-c +- ushift = .true. +- ido = 3 +- go to 9000 +- end if +-c +- 50 continue +-c +-c %------------------------------------% +-c | Back from reverse communication; | +-c | User specified shifts are returned | +-c | in WORKL(1:*NP) | +-c %------------------------------------% +-c +- ushift = .false. +-c +-c +-c %---------------------------------------------------------% +-c | Move the NP shifts to the first NP locations of RITZ to | +-c | free up WORKL. This is for the non-exact shift case; | +-c | in the exact shift case, ssgets already handles this. | +-c %---------------------------------------------------------% +-c +- if (ishift .eq. 0) call scopy (np, workl, 1, ritz, 1) +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [np], ndigit, +- & '_saup2: The number of shifts to apply ') +- call svout (logfil, np, workl, ndigit, +- & '_saup2: shifts selected') +- if (ishift .eq. 1) then +- call svout (logfil, np, bounds, ndigit, +- & '_saup2: corresponding Ritz estimates') +- end if +- end if +-c +-c %---------------------------------------------------------% +-c | Apply the NP0 implicit shifts by QR bulge chasing. | +-c | Each shift is applied to the entire tridiagonal matrix. | +-c | The first 2*N locations of WORKD are used as workspace. | +-c | After ssapps is done, we have a Lanczos | +-c | factorization of length NEV. | +-c %---------------------------------------------------------% +-c +- call ssapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, +- & workd) +-c +-c %---------------------------------------------% +-c | Compute the B-norm of the updated residual. | +-c | Keep B*RESID in WORKD(1:N) to be used in | +-c | the first step of the next call to ssaitr. | +-c %---------------------------------------------% +-c +- cnorm = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call scopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*RESID | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call scopy (n, resid, 1, workd, 1) +- end if +-c +- 100 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(1:N) := B*RESID | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- rnorm = sdot (n, resid, 1, workd, 1) +- rnorm = sqrt(abs(rnorm)) +- else if (bmat .eq. 'I') then +- rnorm = snrm2(n, resid, 1) +- end if +- cnorm = .false. +- 130 continue +-c +- if (msglvl .gt. 2) then +- call svout (logfil, 1, [rnorm], ndigit, +- & '_saup2: B-norm of residual for NEV factorization') +- call svout (logfil, nev, h(1,2), ndigit, +- & '_saup2: main diagonal of compressed H matrix') +- call svout (logfil, nev-1, h(2,1), ndigit, +- & '_saup2: subdiagonal of compressed H matrix') +- end if +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 1100 continue +-c +- mxiter = iter +- nev = nconv +-c +- 1200 continue +- ido = 99 +-c +-c %------------% +-c | Error exit | +-c %------------% +-c +- call arscnd (t1) +- tsaup2 = t1 - t0 +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of ssaup2 | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaupd.f +deleted file mode 100644 +index 9756815270..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssaupd.f ++++ /dev/null +@@ -1,690 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssaupd +-c +-c\Description: +-c +-c Reverse communication interface for the Implicitly Restarted Arnoldi +-c Iteration. For symmetric problems this reduces to a variant of the Lanczos +-c method. This method has been designed to compute approximations to a +-c few eigenpairs of a linear operator OP that is real and symmetric +-c with respect to a real positive semi-definite symmetric matrix B, +-c i.e. +-c +-c B*OP = (OP`)*B. +-c +-c Another way to express this condition is +-c +-c < x,OPy > = < OPx,y > where < z,w > = z`Bw . +-c +-c In the standard eigenproblem B is the identity matrix. +-c ( A` denotes transpose of A) +-c +-c The computed approximate eigenvalues are called Ritz values and +-c the corresponding approximate eigenvectors are called Ritz vectors. +-c +-c ssaupd is usually called iteratively to solve one of the +-c following problems: +-c +-c Mode 1: A*x = lambda*x, A symmetric +-c ===> OP = A and B = I. +-c +-c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite +-c ===> OP = inv[M]*A and B = M. +-c ===> (If M can be factored see remark 3 below) +-c +-c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite +-c ===> OP = (inv[K - sigma*M])*M and B = M. +-c ===> Shift-and-Invert mode +-c +-c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, +-c KG symmetric indefinite +-c ===> OP = (inv[K - sigma*KG])*K and B = K. +-c ===> Buckling mode +-c +-c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite +-c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. +-c ===> Cayley transformed mode +-c +-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +-c should be accomplished either by a direct method +-c using a sparse matrix factorization and solving +-c +-c [A - sigma*M]*w = v or M*w = v, +-c +-c or through an iterative method for solving these +-c systems. If an iterative method is used, the +-c convergence test must be more stringent than +-c the accuracy requirements for the eigenvalue +-c approximations. +-c +-c\Usage: +-c call ssaupd +-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +-c IPNTR, WORKD, WORKL, LWORKL, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to ssaupd. IDO will be set internally to +-c indicate the type of operation to be performed. Control is +-c then given back to the calling routine which has the +-c responsibility to carry out the requested operation and call +-c ssaupd with the result. The operand is given in +-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +-c (If Mode = 2 see remark 5 below) +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c In mode 3,4 and 5, the vector B * X is already +-c available in WORKD(ipntr(3)). It does not +-c need to be recomputed in forming OP * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 3: compute the IPARAM(8) shifts where +-c IPNTR(11) is the pointer into WORKL for +-c placing the shifts. See remark 6 below. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c WHICH Character*2. (INPUT) +-c Specify which of the Ritz values of OP to compute. +-c +-c 'LA' - compute the NEV largest (algebraic) eigenvalues. +-c 'SA' - compute the NEV smallest (algebraic) eigenvalues. +-c 'LM' - compute the NEV largest (in magnitude) eigenvalues. +-c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. +-c 'BE' - compute NEV eigenvalues, half from each end of the +-c spectrum. When NEV is odd, compute one more from the +-c high end than from the low end. +-c (see remark 1 below) +-c +-c NEV Integer. (INPUT) +-c Number of eigenvalues of OP to be computed. 0 < NEV < N. +-c +-c TOL Real scalar. (INPUT) +-c Stopping criterion: the relative accuracy of the Ritz value +-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). +-c If TOL .LE. 0. is passed a default is set: +-c DEFAULT = SLAMCH('EPS') (machine precision as computed +-c by the LAPACK auxiliary subroutine SLAMCH). +-c +-c RESID Real array of length N. (INPUT/OUTPUT) +-c On INPUT: +-c If INFO .EQ. 0, a random initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c On OUTPUT: +-c RESID contains the final residual vector. +-c +-c NCV Integer. (INPUT) +-c Number of columns of the matrix V (less than or equal to N). +-c This will indicate how many Lanczos vectors are generated +-c at each iteration. After the startup phase in which NEV +-c Lanczos vectors are generated, the algorithm generates +-c NCV-NEV Lanczos vectors at each subsequent update iteration. +-c Most of the cost in generating each Lanczos vector is in the +-c matrix-vector product OP*x. (See remark 4 below). +-c +-c V Real N by NCV array. (OUTPUT) +-c The NCV columns of V contain the Lanczos basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c IPARAM Integer array of length 11. (INPUT/OUTPUT) +-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +-c The shifts selected at each iteration are used to restart +-c the Arnoldi iteration in an implicit fashion. +-c ------------------------------------------------------------- +-c ISHIFT = 0: the shifts are provided by the user via +-c reverse communication. The NCV eigenvalues of +-c the current tridiagonal matrix T are returned in +-c the part of WORKL array corresponding to RITZ. +-c See remark 6 below. +-c ISHIFT = 1: exact shifts with respect to the reduced +-c tridiagonal matrix T. This is equivalent to +-c restarting the iteration with a starting vector +-c that is a linear combination of Ritz vectors +-c associated with the "wanted" Ritz values. +-c ------------------------------------------------------------- +-c +-c IPARAM(2) = LEVEC +-c No longer referenced. See remark 2 below. +-c +-c IPARAM(3) = MXITER +-c On INPUT: maximum number of Arnoldi update iterations allowed. +-c On OUTPUT: actual number of Arnoldi update iterations taken. +-c +-c IPARAM(4) = NB: blocksize to be used in the recurrence. +-c The code currently works only for NB = 1. +-c +-c IPARAM(5) = NCONV: number of "converged" Ritz values. +-c This represents the number of Ritz values that satisfy +-c the convergence criterion. +-c +-c IPARAM(6) = IUPD +-c No longer referenced. Implicit restarting is ALWAYS used. +-c +-c IPARAM(7) = MODE +-c On INPUT determines what type of eigenproblem is being solved. +-c Must be 1,2,3,4,5; See under \Description of ssaupd for the +-c five modes available. +-c +-c IPARAM(8) = NP +-c When ido = 3 and the user provides shifts through reverse +-c communication (IPARAM(1)=0), ssaupd returns NP, the number +-c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark +-c 6 below. +-c +-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +-c OUTPUT: NUMOP = total number of OP*x operations, +-c NUMOPB = total number of B*x operations if BMAT='G', +-c NUMREO = total number of steps of re-orthogonalization. +-c +-c IPNTR Integer array of length 11. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD and WORKL +-c arrays for matrices/vectors used by the Lanczos iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X in WORKD. +-c IPNTR(2): pointer to the current result vector Y in WORKD. +-c IPNTR(3): pointer to the vector B * X in WORKD when used in +-c the shift-and-invert mode. +-c IPNTR(4): pointer to the next available location in WORKL +-c that is untouched by the program. +-c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. +-c IPNTR(6): pointer to the NCV RITZ values array in WORKL. +-c IPNTR(7): pointer to the Ritz estimates in array WORKL associated +-c with the Ritz values located in RITZ in WORKL. +-c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. +-c +-c Note: IPNTR(8:10) is only referenced by sseupd. See Remark 2. +-c IPNTR(8): pointer to the NCV RITZ values of the original system. +-c IPNTR(9): pointer to the NCV corresponding error bounds. +-c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors +-c of the tridiagonal matrix T. Only referenced by +-c sseupd if RVEC = .TRUE. See Remarks. +-c ------------------------------------------------------------- +-c +-c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration. Upon termination +-c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired +-c subroutine sseupd uses this output. +-c See Data Distribution Note below. +-c +-c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. See Data Distribution Note below. +-c +-c LWORKL Integer. (INPUT) +-c LWORKL must be at least NCV**2 + 8*NCV . +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal exit. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. IPARAM(5) +-c returns the number of wanted converged Ritz values. +-c = 2: No longer an informational error. Deprecated starting +-c with release 2 of ARPACK. +-c = 3: No shifts could be applied during a cycle of the +-c Implicitly restarted Arnoldi iteration. One possibility +-c is to increase the size of NCV relative to NEV. +-c See remark 4 below. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV must be greater than NEV and less than or equal to N. +-c = -4: The maximum number of Arnoldi update iterations allowed +-c must be greater than zero. +-c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work array WORKL is not sufficient. +-c = -8: Error return from trid. eigenvalue calculation; +-c Informatinal error from LAPACK routine ssteqr. +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3,4,5. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: IPARAM(1) must be equal to 0 or 1. +-c = -13: NEV and WHICH = 'BE' are incompatible. +-c = -9999: Could not build an Arnoldi factorization. +-c IPARAM(5) returns the size of the current Arnoldi +-c factorization. The user is advised to check that +-c enough workspace and array storage has been allocated. +-c +-c +-c\Remarks +-c 1. The converged Ritz values are always returned in ascending +-c algebraic order. The computed Ritz values are approximate +-c eigenvalues of OP. The selection of WHICH should be made +-c with this in mind when Mode = 3,4,5. After convergence, +-c approximate eigenvalues of the original problem may be obtained +-c with the ARPACK subroutine sseupd. +-c +-c 2. If the Ritz vectors corresponding to the converged Ritz values +-c are needed, the user must call sseupd immediately following completion +-c of ssaupd. This is new starting with version 2.1 of ARPACK. +-c +-c 3. If M can be factored into a Cholesky factorization M = LL` +-c then Mode = 2 should not be selected. Instead one should use +-c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +-c linear systems should be solved with L and L` rather +-c than computing inverses. After convergence, an approximate +-c eigenvector z of the original problem is recovered by solving +-c L`z = x where x is a Ritz vector of OP. +-c +-c 4. At present there is no a-priori analysis to guide the selection +-c of NCV relative to NEV. The only formal requirement is that NCV > NEV. +-c However, it is recommended that NCV .ge. 2*NEV. If many problems of +-c the same type are to be solved, one should experiment with increasing +-c NCV while keeping NEV fixed for a given test problem. This will +-c usually decrease the required number of OP*x operations but it +-c also increases the work and storage required to maintain the orthogonal +-c basis vectors. The optimal "cross-over" with respect to CPU time +-c is problem dependent and must be determined empirically. +-c +-c 5. If IPARAM(7) = 2 then in the Reverse communication interface the user +-c must do the following. When IDO = 1, Y = OP * X is to be computed. +-c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user +-c must overwrite X with A*X. Y is then the solution to the linear set +-c of equations B*Y = A*X. +-c +-c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +-c NP = IPARAM(8) shifts in locations: +-c 1 WORKL(IPNTR(11)) +-c 2 WORKL(IPNTR(11)+1) +-c . +-c . +-c . +-c NP WORKL(IPNTR(11)+NP-1). +-c +-c The eigenvalues of the current tridiagonal matrix are located in +-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the +-c order defined by WHICH. The associated Ritz estimates are located in +-c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). +-c +-c----------------------------------------------------------------------- +-c +-c\Data Distribution Note: +-c +-c Fortran-D syntax: +-c ================ +-c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) +-c DECOMPOSE D1(N), D2(N,NCV) +-c ALIGN RESID(I) with D1(I) +-c ALIGN V(I,J) with D2(I,J) +-c ALIGN WORKD(I) with D1(I) range (1:N) +-c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) +-c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) +-c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) +-c REPLICATED WORKL(LWORKL) +-c +-c Cray MPP syntax: +-c =============== +-c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) +-c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) +-c REPLICATED WORKL(LWORKL) +-c +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +-c 1980. +-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +-c Computer Physics Communications, 53 (1989), pp 169-179. +-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +-c Implement the Spectral Transformation", Math. Comp., 48 (1987), +-c pp 663-673. +-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +-c SIAM J. Matr. Anal. Apps., January (1993). +-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +-c for Updating the QR decomposition", ACM TOMS, December 1990, +-c Volume 16 Number 4, pp 369-377. +-c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral +-c Transformations in a k-Step Arnoldi Method". In Preparation. +-c +-c\Routines called: +-c ssaup2 ARPACK routine that implements the Implicitly Restarted +-c Arnoldi Iteration. +-c sstats ARPACK routine that initialize timing and other statistics +-c variables. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine that prints vectors. +-c slamch LAPACK routine that determines machine constants. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\Remarks +-c 1. None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssaupd +- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, +- & ipntr, workd, workl, lworkl, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ldv, lworkl, n, ncv, nev +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(11) +- Real +- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0 , zero = 0.0E+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, msglvl, mxiter, mode, nb, +- & nev0, next, np, ritz, j +- save bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, msglvl, mxiter, mode, nb, +- & nev0, next, np, ritz +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external ssaup2, svout, ivout, arscnd, sstats +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slamch +- external slamch +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call sstats +- call arscnd (t0) +- msglvl = msaupd +-c +- ierr = 0 +- ishift = iparam(1) +- mxiter = iparam(3) +-c nb = iparam(4) +- nb = 1 +-c +-c %--------------------------------------------% +-c | Revision 2 performs only implicit restart. | +-c %--------------------------------------------% +-c +- iupd = 1 +- mode = iparam(7) +-c +-c %----------------% +-c | Error checking | +-c %----------------% +-c +- if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev .or. ncv .gt. n) then +- ierr = -3 +- end if +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c %----------------------------------------------% +-c +- np = ncv - nev +-c +- if (mxiter .le. 0) ierr = -4 +- if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LA' .and. +- & which .ne. 'SA' .and. +- & which .ne. 'BE') ierr = -5 +- if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 +-c +- if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 +- if (mode .lt. 1 .or. mode .gt. 5) then +- ierr = -10 +- else if (mode .eq. 1 .and. bmat .eq. 'G') then +- ierr = -11 +- else if (ishift .lt. 0 .or. ishift .gt. 1) then +- ierr = -12 +- else if (nev .eq. 1 .and. which .eq. 'BE') then +- ierr = -13 +- end if +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- ido = 99 +- go to 9000 +- end if +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- if (nb .le. 0) nb = 1 +- if (tol .le. zero) tol = slamch('EpsMach') +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c | NEV0 is the local variable designating the | +-c | size of the invariant subspace desired. | +-c %----------------------------------------------% +-c +- np = ncv - nev +- nev0 = nev +-c +-c %-----------------------------% +-c | Zero out internal workspace | +-c %-----------------------------% +-c +- do 10 j = 1, ncv**2 + 8*ncv +- workl(j) = zero +- 10 continue +-c +-c %-------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:2*ncv) := generated tridiagonal matrix | +-c | workl(2*ncv+1:2*ncv+ncv) := ritz values | +-c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | +-c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | +-c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | +-c %-------------------------------------------------------% +-c +- ldh = ncv +- ldq = ncv +- ih = 1 +- ritz = ih + 2*ldh +- bounds = ritz + ncv +- iq = bounds + ncv +- iw = iq + ncv**2 +- next = iw + 3*ncv +-c +- ipntr(4) = next +- ipntr(5) = ih +- ipntr(6) = ritz +- ipntr(7) = bounds +- ipntr(11) = iw +- end if +-c +-c %-------------------------------------------------------% +-c | Carry out the Implicitly restarted Lanczos Iteration. | +-c %-------------------------------------------------------% +-c +- call ssaup2 +- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), +- & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, +- & info ) +-c +-c %--------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP or shifts. | +-c %--------------------------------------------------% +-c +- if (ido .eq. 3) iparam(8) = np +- if (ido .ne. 99) go to 9000 +-c +- iparam(3) = mxiter +- iparam(5) = np +- iparam(9) = nopx +- iparam(10) = nbx +- iparam(11) = nrorth +-c +-c %------------------------------------% +-c | Exit if there was an informational | +-c | error within ssaup2. | +-c %------------------------------------% +-c +- if (info .lt. 0) go to 9000 +- if (info .eq. 2) info = 3 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [mxiter], ndigit, +- & '_saupd: number of update iterations taken') +- call ivout (logfil, 1, [np], ndigit, +- & '_saupd: number of "converged" Ritz values') +- call svout (logfil, np, workl(Ritz), ndigit, +- & '_saupd: final Ritz values') +- call svout (logfil, np, workl(Bounds), ndigit, +- & '_saupd: corresponding error bounds') +- end if +-c +- call arscnd (t1) +- tsaupd = t1 - t0 +-c +- if (msglvl .gt. 0) then +-c +-c %--------------------------------------------------------% +-c | Version Number & Version Date are defined in version.h | +-c %--------------------------------------------------------% +-c +- write (6,1000) +- write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, +- & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, +- & tgetv0, tseigt, tsgets, tsapps, tsconv +- 1000 format (//, +- & 5x, '==========================================',/ +- & 5x, '= Symmetric implicit Arnoldi update code =',/ +- & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ +- & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ +- & 5x, '==========================================',/ +- & 5x, '= Summary of timing statistics =',/ +- & 5x, '==========================================',//) +- 1100 format ( +- & 5x, 'Total number update iterations = ', i5,/ +- & 5x, 'Total number of OP*x operations = ', i5,/ +- & 5x, 'Total number of B*x operations = ', i5,/ +- & 5x, 'Total number of reorthogonalization steps = ', i5,/ +- & 5x, 'Total number of iterative refinement steps = ', i5,/ +- & 5x, 'Total number of restart steps = ', i5,/ +- & 5x, 'Total time in user OP*x operation = ', f12.6,/ +- & 5x, 'Total time in user B*x operation = ', f12.6,/ +- & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ +- & 5x, 'Total time in saup2 routine = ', f12.6,/ +- & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ +- & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ +- & 5x, 'Total time in (re)start vector generation = ', f12.6,/ +- & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ +- & 5x, 'Total time in getting the shifts = ', f12.6,/ +- & 5x, 'Total time in applying the shifts = ', f12.6,/ +- & 5x, 'Total time in convergence testing = ', f12.6) +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of ssaupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssconv.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssconv.f +deleted file mode 100644 +index 11e4cab262..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssconv.f ++++ /dev/null +@@ -1,138 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssconv +-c +-c\Description: +-c Convergence testing for the symmetric Arnoldi eigenvalue routine. +-c +-c\Usage: +-c call ssconv +-c ( N, RITZ, BOUNDS, TOL, NCONV ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Number of Ritz values to check for convergence. +-c +-c RITZ Real array of length N. (INPUT) +-c The Ritz values to be checked for convergence. +-c +-c BOUNDS Real array of length N. (INPUT) +-c Ritz estimates associated with the Ritz values in RITZ. +-c +-c TOL Real scalar. (INPUT) +-c Desired relative accuracy for a Ritz value to be considered +-c "converged". +-c +-c NCONV Integer scalar. (OUTPUT) +-c Number of "converged" Ritz values. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c slamch LAPACK routine that determines machine constants. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\Remarks +-c 1. Starting with version 2.4, this routine no longer uses the +-c Parlett strategy using the gap conditions. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssconv (n, ritz, bounds, tol, nconv) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer n, nconv +- Real +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & ritz(n), bounds(n) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i +- Real +- & temp, eps23 +-c +-c %-------------------% +-c | External routines | +-c %-------------------% +-c +- Real +- & slamch +- external slamch +- +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic abs +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- call arscnd (t0) +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0) +-c +- nconv = 0 +- do 10 i = 1, n +-c +-c %-----------------------------------------------------% +-c | The i-th Ritz value is considered "converged" | +-c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | +-c %-----------------------------------------------------% +-c +- temp = max( eps23, abs(ritz(i)) ) +- if ( bounds(i) .le. tol*temp ) then +- nconv = nconv + 1 +- end if +-c +- 10 continue +-c +- call arscnd (t1) +- tsconv = tsconv + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of ssconv | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseigt.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseigt.f +deleted file mode 100644 +index 3ac336690b..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseigt.f ++++ /dev/null +@@ -1,181 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: sseigt +-c +-c\Description: +-c Compute the eigenvalues of the current symmetric tridiagonal matrix +-c and the corresponding error bounds given the current residual norm. +-c +-c\Usage: +-c call sseigt +-c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) +-c +-c\Arguments +-c RNORM Real scalar. (INPUT) +-c RNORM contains the residual norm corresponding to the current +-c symmetric tridiagonal matrix H. +-c +-c N Integer. (INPUT) +-c Size of the symmetric tridiagonal matrix H. +-c +-c H Real N by 2 array. (INPUT) +-c H contains the symmetric tridiagonal matrix with the +-c subdiagonal in the first column starting at H(2,1) and the +-c main diagonal in second column. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c EIG Real array of length N. (OUTPUT) +-c On output, EIG contains the N eigenvalues of H possibly +-c unsorted. The BOUNDS arrays are returned in the +-c same sorted order as EIG. +-c +-c BOUNDS Real array of length N. (OUTPUT) +-c On output, BOUNDS contains the error estimates corresponding +-c to the eigenvalues EIG. This is equal to RNORM times the +-c last components of the eigenvectors corresponding to the +-c eigenvalues in EIG. +-c +-c WORKL Real work array of length 3*N. (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c IERR Integer. (OUTPUT) +-c Error exit flag from sstqrb. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c sstqrb ARPACK routine that computes the eigenvalues and the +-c last components of the eigenvectors of a symmetric +-c and tridiagonal matrix. +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine that prints vectors. +-c scopy Level 1 BLAS that copies one vector to another. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.4' +-c +-c\SCCS Information: @(#) +-c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine sseigt +- & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer ierr, ldh, n +- Real +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & eig(n), bounds(n), h(ldh,2), workl(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & zero +- parameter (zero = 0.0E+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, k, msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy, sstqrb, svout, arscnd +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mseigt +-c +- if (msglvl .gt. 0) then +- call svout (logfil, n, h(1,2), ndigit, +- & '_seigt: main diagonal of matrix H') +- if (n .gt. 1) then +- call svout (logfil, n-1, h(2,1), ndigit, +- & '_seigt: sub diagonal of matrix H') +- end if +- end if +-c +- call scopy (n, h(1,2), 1, eig, 1) +- call scopy (n-1, h(2,1), 1, workl, 1) +- call sstqrb (n, eig, workl, bounds, workl(n+1), ierr) +- if (ierr .ne. 0) go to 9000 +- if (msglvl .gt. 1) then +- call svout (logfil, n, bounds, ndigit, +- & '_seigt: last row of the eigenvector matrix for H') +- end if +-c +-c %-----------------------------------------------% +-c | Finally determine the error bounds associated | +-c | with the n Ritz values of H. | +-c %-----------------------------------------------% +-c +- do 30 k = 1, n +- bounds(k) = rnorm*abs(bounds(k)) +- 30 continue +-c +- call arscnd (t1) +- tseigt = tseigt + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of sseigt | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssesrt.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssesrt.f +deleted file mode 100644 +index afc71b0882..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssesrt.f ++++ /dev/null +@@ -1,217 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssesrt +-c +-c\Description: +-c Sort the array X in the order specified by WHICH and optionally +-c apply the permutation to the columns of the matrix A. +-c +-c\Usage: +-c call ssesrt +-c ( WHICH, APPLY, N, X, NA, A, LDA) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> X is sorted into increasing order of magnitude. +-c 'SM' -> X is sorted into decreasing order of magnitude. +-c 'LA' -> X is sorted into increasing order of algebraic. +-c 'SA' -> X is sorted into decreasing order of algebraic. +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to A. +-c APPLY = .FALSE. -> do not apply the sorted order to A. +-c +-c N Integer. (INPUT) +-c Dimension of the array X. +-c +-c X Real array of length N. (INPUT/OUTPUT) +-c The array to be sorted. +-c +-c NA Integer. (INPUT) +-c Number of rows of the matrix A. +-c +-c A Real array of length NA by N. (INPUT/OUTPUT) +-c +-c LDA Integer. (INPUT) +-c Leading dimension of A. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Routines +-c sswap Level 1 BLAS that swaps the contents of two vectors. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.1'. +-c Adapted from the sort routine in LANSO and +-c the ARPACK code ssortr +-c +-c\SCCS Information: @(#) +-c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssesrt (which, apply, n, x, na, a, lda) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer lda, n, na +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & x(0:n-1), a(lda, 0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Real +- & temp +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external sswap +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'SA') then +-c +-c X is sorted into decreasing order of algebraic. +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- if (x(j).lt.x(j+igap)) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 30 +- endif +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c X is sorted into decreasing order of magnitude. +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j.lt.0) go to 60 +-c +- if (abs(x(j)).lt.abs(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LA') then +-c +-c X is sorted into increasing order of algebraic. +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (x(j).gt.x(j+igap)) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'LM') then +-c +-c X is sorted into increasing order of magnitude. +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (abs(x(j)).gt.abs(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +- if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of ssesrt | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseupd.f +deleted file mode 100644 +index 03ba7ac508..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sseupd.f ++++ /dev/null +@@ -1,867 +0,0 @@ +-c\BeginDoc +-c +-c\Name: sseupd +-c +-c\Description: +-c +-c This subroutine returns the converged approximations to eigenvalues +-c of A*z = lambda*B*z and (optionally): +-c +-c (1) the corresponding approximate eigenvectors, +-c +-c (2) an orthonormal (Lanczos) basis for the associated approximate +-c invariant subspace, +-c +-c (3) Both. +-c +-c There is negligible additional cost to obtain eigenvectors. An orthonormal +-c (Lanczos) basis is always computed. There is an additional storage cost +-c of n*nev if both are requested (in this case a separate array Z must be +-c supplied). +-c +-c These quantities are obtained from the Lanczos factorization computed +-c by SSAUPD for the linear operator OP prescribed by the MODE selection +-c (see IPARAM(7) in SSAUPD documentation.) SSAUPD must be called before +-c this routine is called. These approximate eigenvalues and vectors are +-c commonly called Ritz values and Ritz vectors respectively. They are +-c referred to as such in the comments that follow. The computed orthonormal +-c basis for the invariant subspace corresponding to these Ritz values is +-c referred to as a Lanczos basis. +-c +-c See documentation in the header of the subroutine SSAUPD for a definition +-c of OP as well as other terms and the relation of computed Ritz values +-c and vectors of OP with respect to the given problem A*z = lambda*B*z. +-c +-c The approximate eigenvalues of the original problem are returned in +-c ascending algebraic order. The user may elect to call this routine +-c once for each desired Ritz vector and store it peripherally if desired. +-c There is also the option of computing a selected set of these vectors +-c with a single call. +-c +-c\Usage: +-c call sseupd +-c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, +-c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) +-c +-c RVEC LOGICAL (INPUT) +-c Specifies whether Ritz vectors corresponding to the Ritz value +-c approximations to the eigenproblem A*z = lambda*B*z are computed. +-c +-c RVEC = .FALSE. Compute Ritz values only. +-c +-c RVEC = .TRUE. Compute Ritz vectors. +-c +-c HOWMNY Character*1 (INPUT) +-c Specifies how many Ritz vectors are wanted and the form of Z +-c the matrix of Ritz vectors. See remark 1 below. +-c = 'A': compute NEV Ritz vectors; +-c = 'S': compute some of the Ritz vectors, specified +-c by the logical array SELECT. +-c +-c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) +-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +-c computed. To select the Ritz vector corresponding to a +-c Ritz value D(j), SELECT(j) must be set to .TRUE.. +-c If HOWMNY = 'A' , SELECT is used as a workspace for +-c reordering the Ritz values. +-c +-c D Real array of dimension NEV. (OUTPUT) +-c On exit, D contains the Ritz value approximations to the +-c eigenvalues of A*z = lambda*B*z. The values are returned +-c in ascending order. If IPARAM(7) = 3,4,5 then D represents +-c the Ritz values of OP computed by ssaupd transformed to +-c those of the original eigensystem A*z = lambda*B*z. If +-c IPARAM(7) = 1,2 then the Ritz values of OP are the same +-c as the those of A*z = lambda*B*z. +-c +-c Z Real N by NEV array if HOWMNY = 'A'. (OUTPUT) +-c On exit, Z contains the B-orthonormal Ritz vectors of the +-c eigensystem A*z = lambda*B*z corresponding to the Ritz +-c value approximations. +-c If RVEC = .FALSE. then Z is not referenced. +-c NOTE: The array Z may be set equal to first NEV columns of the +-c Arnoldi/Lanczos basis array V computed by SSAUPD. +-c +-c LDZ Integer. (INPUT) +-c The leading dimension of the array Z. If Ritz vectors are +-c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. +-c +-c SIGMA Real (INPUT) +-c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if +-c IPARAM(7) = 1 or 2. +-c +-c +-c **** The remaining arguments MUST be the same as for the **** +-c **** call to SSAUPD that was just completed. **** +-c +-c NOTE: The remaining arguments +-c +-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +-c WORKD, WORKL, LWORKL, INFO +-c +-c must be passed directly to SSEUPD following the last call +-c to SSAUPD. These arguments MUST NOT BE MODIFIED between +-c the the last call to SSAUPD and the call to SSEUPD. +-c +-c Two of these parameters (WORKL, INFO) are also output parameters: +-c +-c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) +-c WORKL(1:4*ncv) contains information obtained in +-c ssaupd. They are not changed by sseupd. +-c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the +-c untransformed Ritz values, the computed error estimates, +-c and the associated eigenvector matrix of H. +-c +-c Note: IPNTR(8:10) contains the pointer into WORKL for addresses +-c of the above information computed by sseupd. +-c ------------------------------------------------------------- +-c IPNTR(8): pointer to the NCV RITZ values of the original system. +-c IPNTR(9): pointer to the NCV corresponding error bounds. +-c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors +-c of the tridiagonal matrix T. Only referenced by +-c sseupd if RVEC = .TRUE. See Remarks. +-c ------------------------------------------------------------- +-c +-c INFO Integer. (OUTPUT) +-c Error flag on output. +-c = 0: Normal exit. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV must be greater than NEV and less than or equal to N. +-c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work WORKL array is not sufficient. +-c = -8: Error return from trid. eigenvalue calculation; +-c Information error from LAPACK routine ssteqr. +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3,4,5. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: NEV and WHICH = 'BE' are incompatible. +-c = -14: SSAUPD did not find any eigenvalues to sufficient +-c accuracy. +-c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. +-c = -16: HOWMNY = 'S' not yet implemented +-c = -17: SSEUPD got a different count of the number of converged +-c Ritz values than SSAUPD got. This indicates the user +-c probably made an error in passing data from SSAUPD to +-c SSEUPD or that the data was modified before entering +-c SSEUPD. +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, +-c 1980. +-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", +-c Computer Physics Communications, 53 (1989), pp 169-179. +-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to +-c Implement the Spectral Transformation", Math. Comp., 48 (1987), +-c pp 663-673. +-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos +-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", +-c SIAM J. Matr. Anal. Apps., January (1993). +-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines +-c for Updating the QR decomposition", ACM TOMS, December 1990, +-c Volume 16 Number 4, pp 369-377. +-c +-c\Remarks +-c 1. The converged Ritz values are always returned in increasing +-c (algebraic) order. +-c +-c 2. Currently only HOWMNY = 'A' is implemented. It is included at this +-c stage for the user who wants to incorporate it. +-c +-c\Routines called: +-c ssesrt ARPACK routine that sorts an array X, and applies the +-c corresponding permutation to a matrix A. +-c ssortr ssortr ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c svout ARPACK utility routine that prints vectors. +-c sgeqr2 LAPACK routine that computes the QR factorization of +-c a matrix. +-c slacpy LAPACK matrix copy routine. +-c slamch LAPACK routine that determines machine constants. +-c sorm2r LAPACK routine that applies an orthogonal matrix in +-c factored form. +-c ssteqr LAPACK routine that computes eigenvalues and eigenvectors +-c of a tridiagonal matrix. +-c sger Level 2 BLAS rank one update to a matrix. +-c scopy Level 1 BLAS that copies one vector to another . +-c snrm2 Level 1 BLAS that computes the norm of a vector. +-c sscal Level 1 BLAS that scales a vector. +-c sswap Level 1 BLAS that swaps the contents of two vectors. +- +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/15/93: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +- subroutine sseupd(rvec , howmny, select, d , +- & z , ldz , sigma , bmat , +- & n , which , nev , tol , +- & resid , ncv , v , ldv , +- & iparam, ipntr , workd , workl, +- & lworkl, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat, howmny, which*2 +- logical rvec +- integer info, ldz, ldv, lworkl, n, ncv, nev +- Real +- & sigma, tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(7), ipntr(11) +- logical select(ncv) +- Real +- & d(nev) , resid(n) , v(ldv,ncv), +- & z(ldz, nev), workd(2*n), workl(lworkl) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0 , zero = 0.0E+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character type*6 +- integer bounds , ierr , ih , ihb , ihd , +- & iq , iw , j , k , ldh , +- & ldq , mode , msglvl, nconv , next , +- & ritz , irz , ibd , np , ishift, +- & leftptr, rghtptr, numcnv, jj +- Real +- & bnorm2 , rnorm, temp, temp1, eps23 +- logical reord +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external scopy , sger , sgeqr2, slacpy, sorm2r, sscal, +- & ssesrt, ssteqr, sswap , svout , ivout , ssortr +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & snrm2, slamch +- external snrm2, slamch +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic min +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- msglvl = mseupd +- mode = iparam(7) +- nconv = iparam(5) +- info = 0 +-c +-c %--------------% +-c | Quick return | +-c %--------------% +-c +- if (nconv .eq. 0) go to 9000 +- ierr = 0 +-c +- if (nconv .le. 0) ierr = -14 +- if (n .le. 0) ierr = -1 +- if (nev .le. 0) ierr = -2 +- if (ncv .le. nev .or. ncv .gt. n) ierr = -3 +- if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LA' .and. +- & which .ne. 'SA' .and. +- & which .ne. 'BE') ierr = -5 +- if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 +- if ( (howmny .ne. 'A' .and. +- & howmny .ne. 'P' .and. +- & howmny .ne. 'S') .and. rvec ) +- & ierr = -15 +- if (rvec .and. howmny .eq. 'S') ierr = -16 +-c +- if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 +-c +- if (mode .eq. 1 .or. mode .eq. 2) then +- type = 'REGULR' +- else if (mode .eq. 3 ) then +- type = 'SHIFTI' +- else if (mode .eq. 4 ) then +- type = 'BUCKLE' +- else if (mode .eq. 5 ) then +- type = 'CAYLEY' +- else +- ierr = -10 +- end if +- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +- if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- go to 9000 +- end if +-c +-c %-------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:2*ncv) := generated tridiagonal matrix H | +-c | The subdiagonal is stored in workl(2:ncv). | +-c | The dead spot is workl(1) but upon exiting | +-c | ssaupd stores the B-norm of the last residual | +-c | vector in workl(1). We use this !!! | +-c | workl(2*ncv+1:2*ncv+ncv) := ritz values | +-c | The wanted values are in the first NCONV spots. | +-c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | +-c | The wanted values are in the first NCONV spots. | +-c | NOTE: workl(1:4*ncv) is set by ssaupd and is not | +-c | modified by sseupd. | +-c %-------------------------------------------------------% +-c +-c %-------------------------------------------------------% +-c | The following is used and set by sseupd. | +-c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | +-c | computation of the eigenvectors of H. Stores | +-c | the diagonal of H. Upon EXIT contains the NCV | +-c | Ritz values of the original system. The first | +-c | NCONV spots have the wanted values. If MODE = | +-c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | +-c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | +-c | computation of the eigenvectors of H. Stores | +-c | the subdiagonal of H. Upon EXIT contains the | +-c | NCV corresponding Ritz estimates of the | +-c | original system. The first NCONV spots have the | +-c | wanted values. If MODE = 1,2 then will equal | +-c | workl(3*ncv+1:4*ncv). | +-c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | +-c | the eigenvector matrix for H as returned by | +-c | ssteqr. Not referenced if RVEC = .False. | +-c | Ordering follows that of workl(4*ncv+1:5*ncv) | +-c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | +-c | Workspace. Needed by ssteqr and by sseupd. | +-c | GRAND total of NCV*(NCV+8) locations. | +-c %-------------------------------------------------------% +-c +-c +- ih = ipntr(5) +- ritz = ipntr(6) +- bounds = ipntr(7) +- ldh = ncv +- ldq = ncv +- ihd = bounds + ldh +- ihb = ihd + ldh +- iq = ihb + ldh +- iw = iq + ldh*ncv +- next = iw + 2*ncv +- ipntr(4) = next +- ipntr(8) = ihd +- ipntr(9) = ihb +- ipntr(10) = iq +-c +-c %----------------------------------------% +-c | irz points to the Ritz values computed | +-c | by _seigt before exiting _saup2. | +-c | ibd points to the Ritz estimates | +-c | computed by _seigt before exiting | +-c | _saup2. | +-c %----------------------------------------% +-c +- irz = ipntr(11)+ncv +- ibd = irz+ncv +-c +-c +-c %---------------------------------% +-c | Set machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = slamch('Epsilon-Machine') +- eps23 = eps23**(2.0E+0 / 3.0E+0 ) +-c +-c %---------------------------------------% +-c | RNORM is B-norm of the RESID(1:N). | +-c | BNORM2 is the 2 norm of B*RESID(1:N). | +-c | Upon exit of ssaupd WORKD(1:N) has | +-c | B*RESID(1:N). | +-c %---------------------------------------% +-c +- rnorm = workl(ih) +- if (bmat .eq. 'I') then +- bnorm2 = rnorm +- else if (bmat .eq. 'G') then +- bnorm2 = snrm2(n, workd, 1) +- end if +-c +- if (msglvl .gt. 2) then +- call svout(logfil, ncv, workl(irz), ndigit, +- & '_seupd: Ritz values passed in from _SAUPD.') +- call svout(logfil, ncv, workl(ibd), ndigit, +- & '_seupd: Ritz estimates passed in from _SAUPD.') +- end if +-c +- if (rvec) then +-c +- reord = .false. +-c +-c %---------------------------------------------------% +-c | Use the temporary bounds array to store indices | +-c | These will be used to mark the select array later | +-c %---------------------------------------------------% +-c +- do 10 j = 1,ncv +- workl(bounds+j-1) = j +- select(j) = .false. +- 10 continue +-c +-c %-------------------------------------% +-c | Select the wanted Ritz values. | +-c | Sort the Ritz values so that the | +-c | wanted ones appear at the tailing | +-c | NEV positions of workl(irr) and | +-c | workl(iri). Move the corresponding | +-c | error estimates in workl(bound) | +-c | accordingly. | +-c %-------------------------------------% +-c +- np = ncv - nev +- ishift = 0 +- call ssgets(ishift, which , nev , +- & np , workl(irz) , workl(bounds), +- & workl) +-c +- if (msglvl .gt. 2) then +- call svout(logfil, ncv, workl(irz), ndigit, +- & '_seupd: Ritz values after calling _SGETS.') +- call svout(logfil, ncv, workl(bounds), ndigit, +- & '_seupd: Ritz value indices after calling _SGETS.') +- end if +-c +-c %-----------------------------------------------------% +-c | Record indices of the converged wanted Ritz values | +-c | Mark the select array for possible reordering | +-c %-----------------------------------------------------% +-c +- numcnv = 0 +- do 11 j = 1,ncv +- temp1 = max(eps23, abs(workl(irz+ncv-j)) ) +- jj = workl(bounds + ncv - j) +- if (numcnv .lt. nconv .and. +- & workl(ibd+jj-1) .le. tol*temp1) then +- select(jj) = .true. +- numcnv = numcnv + 1 +- if (jj .gt. nconv) reord = .true. +- endif +- 11 continue +-c +-c %-----------------------------------------------------------% +-c | Check the count (numcnv) of converged Ritz values with | +-c | the number (nconv) reported by _saupd. If these two | +-c | are different then there has probably been an error | +-c | caused by incorrect passing of the _saupd data. | +-c %-----------------------------------------------------------% +-c +- if (msglvl .gt. 2) then +- call ivout(logfil, 1, [numcnv], ndigit, +- & '_seupd: Number of specified eigenvalues') +- call ivout(logfil, 1, [nconv], ndigit, +- & '_seupd: Number of "converged" eigenvalues') +- end if +-c +- if (numcnv .ne. nconv) then +- info = -17 +- go to 9000 +- end if +-c +-c %-----------------------------------------------------------% +-c | Call LAPACK routine _steqr to compute the eigenvalues and | +-c | eigenvectors of the final symmetric tridiagonal matrix H. | +-c | Initialize the eigenvector matrix Q to the identity. | +-c %-----------------------------------------------------------% +-c +- call scopy(ncv-1, workl(ih+1), 1, workl(ihb), 1) +- call scopy(ncv, workl(ih+ldh), 1, workl(ihd), 1) +-c +- call ssteqr('Identity', ncv, workl(ihd), workl(ihb), +- & workl(iq) , ldq, workl(iw), ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 9000 +- end if +-c +- if (msglvl .gt. 1) then +- call scopy(ncv, workl(iq+ncv-1), ldq, workl(iw), 1) +- call svout(logfil, ncv, workl(ihd), ndigit, +- & '_seupd: NCV Ritz values of the final H matrix') +- call svout(logfil, ncv, workl(iw), ndigit, +- & '_seupd: last row of the eigenvector matrix for H') +- end if +-c +- if (reord) then +-c +-c %---------------------------------------------% +-c | Reordered the eigenvalues and eigenvectors | +-c | computed by _steqr so that the "converged" | +-c | eigenvalues appear in the first NCONV | +-c | positions of workl(ihd), and the associated | +-c | eigenvectors appear in the first NCONV | +-c | columns. | +-c %---------------------------------------------% +-c +- leftptr = 1 +- rghtptr = ncv +-c +- if (ncv .eq. 1) go to 30 +-c +- 20 if (select(leftptr)) then +-c +-c %-------------------------------------------% +-c | Search, from the left, for the first Ritz | +-c | value that has not converged. | +-c %-------------------------------------------% +-c +- leftptr = leftptr + 1 +-c +- else if ( .not. select(rghtptr)) then +-c +-c %----------------------------------------------% +-c | Search, from the right, the first Ritz value | +-c | that has converged. | +-c %----------------------------------------------% +-c +- rghtptr = rghtptr - 1 +-c +- else +-c +-c %----------------------------------------------% +-c | Swap the Ritz value on the left that has not | +-c | converged with the Ritz value on the right | +-c | that has converged. Swap the associated | +-c | eigenvector of the tridiagonal matrix H as | +-c | well. | +-c %----------------------------------------------% +-c +- temp = workl(ihd+leftptr-1) +- workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) +- workl(ihd+rghtptr-1) = temp +- call scopy(ncv, workl(iq+ncv*(leftptr-1)), 1, +- & workl(iw), 1) +- call scopy(ncv, workl(iq+ncv*(rghtptr-1)), 1, +- & workl(iq+ncv*(leftptr-1)), 1) +- call scopy(ncv, workl(iw), 1, +- & workl(iq+ncv*(rghtptr-1)), 1) +- leftptr = leftptr + 1 +- rghtptr = rghtptr - 1 +-c +- end if +-c +- if (leftptr .lt. rghtptr) go to 20 +-c +- end if +-c +- 30 if (msglvl .gt. 2) then +- call svout (logfil, ncv, workl(ihd), ndigit, +- & '_seupd: The eigenvalues of H--reordered') +- end if +-c +-c %----------------------------------------% +-c | Load the converged Ritz values into D. | +-c %----------------------------------------% +-c +- call scopy(nconv, workl(ihd), 1, d, 1) +-c +- else +-c +-c %-----------------------------------------------------% +-c | Ritz vectors not required. Load Ritz values into D. | +-c %-----------------------------------------------------% +-c +- call scopy(nconv, workl(ritz), 1, d, 1) +- call scopy(ncv, workl(ritz), 1, workl(ihd), 1) +-c +- end if +-c +-c %------------------------------------------------------------------% +-c | Transform the Ritz values and possibly vectors and corresponding | +-c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | +-c | (and corresponding data) are returned in ascending order. | +-c %------------------------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +-c +-c %---------------------------------------------------------% +-c | Ascending sort of wanted Ritz values, vectors and error | +-c | bounds. Not necessary if only Ritz values are desired. | +-c %---------------------------------------------------------% +-c +- if (rvec) then +- call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) +- else +- call scopy(ncv, workl(bounds), 1, workl(ihb), 1) +- end if +-c +- else +-c +-c %-------------------------------------------------------------% +-c | * Make a copy of all the Ritz values. | +-c | * Transform the Ritz values back to the original system. | +-c | For TYPE = 'SHIFTI' the transformation is | +-c | lambda = 1/theta + sigma | +-c | For TYPE = 'BUCKLE' the transformation is | +-c | lambda = sigma * theta / ( theta - 1 ) | +-c | For TYPE = 'CAYLEY' the transformation is | +-c | lambda = sigma * (theta + 1) / (theta - 1 ) | +-c | where the theta are the Ritz values returned by ssaupd. | +-c | NOTES: | +-c | *The Ritz vectors are not affected by the transformation. | +-c | They are only reordered. | +-c %-------------------------------------------------------------% +-c +- call scopy (ncv, workl(ihd), 1, workl(iw), 1) +- if (type .eq. 'SHIFTI') then +- do 40 k=1, ncv +- workl(ihd+k-1) = one / workl(ihd+k-1) + sigma +- 40 continue +- else if (type .eq. 'BUCKLE') then +- do 50 k=1, ncv +- workl(ihd+k-1) = sigma * workl(ihd+k-1) / +- & (workl(ihd+k-1) - one) +- 50 continue +- else if (type .eq. 'CAYLEY') then +- do 60 k=1, ncv +- workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / +- & (workl(ihd+k-1) - one) +- 60 continue +- end if +-c +-c %-------------------------------------------------------------% +-c | * Store the wanted NCONV lambda values into D. | +-c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | +-c | into ascending order and apply sort to the NCONV theta | +-c | values in the transformed system. We will need this to | +-c | compute Ritz estimates in the original system. | +-c | * Finally sort the lambda`s into ascending order and apply | +-c | to Ritz vectors if wanted. Else just sort lambda`s into | +-c | ascending order. | +-c | NOTES: | +-c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | +-c | match the ordering of the lambda. We`ll use them again for | +-c | Ritz vector purification. | +-c %-------------------------------------------------------------% +-c +- call scopy(nconv, workl(ihd), 1, d, 1) +- call ssortr('LA', .true., nconv, workl(ihd), workl(iw)) +- if (rvec) then +- call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) +- else +- call scopy(ncv, workl(bounds), 1, workl(ihb), 1) +- call sscal(ncv, bnorm2/rnorm, workl(ihb), 1) +- call ssortr('LA', .true., nconv, d, workl(ihb)) +- end if +-c +- end if +-c +-c %------------------------------------------------% +-c | Compute the Ritz vectors. Transform the wanted | +-c | eigenvectors of the symmetric tridiagonal H by | +-c | the Lanczos basis matrix V. | +-c %------------------------------------------------% +-c +- if (rvec .and. howmny .eq. 'A') then +-c +-c %----------------------------------------------------------% +-c | Compute the QR factorization of the matrix representing | +-c | the wanted invariant subspace located in the first NCONV | +-c | columns of workl(iq,ldq). | +-c %----------------------------------------------------------% +-c +- call sgeqr2(ncv, nconv , workl(iq) , +- & ldq, workl(iw+ncv), workl(ihb), +- & ierr) +-c +-c %--------------------------------------------------------% +-c | * Postmultiply V by Q. | +-c | * Copy the first NCONV columns of VQ into Z. | +-c | The N by NCONV matrix Z is now a matrix representation | +-c | of the approximate invariant subspace associated with | +-c | the Ritz values in workl(ihd). | +-c %--------------------------------------------------------% +-c +- call sorm2r('Right', 'Notranspose', n , +- & ncv , nconv , workl(iq), +- & ldq , workl(iw+ncv), v , +- & ldv , workd(n+1) , ierr) +- call slacpy('All', n, nconv, v, ldv, z, ldz) +-c +-c %-----------------------------------------------------% +-c | In order to compute the Ritz estimates for the Ritz | +-c | values in both systems, need the last row of the | +-c | eigenvector matrix. Remember, it`s in factored form | +-c %-----------------------------------------------------% +-c +- do 65 j = 1, ncv-1 +- workl(ihb+j-1) = zero +- 65 continue +- workl(ihb+ncv-1) = one +- call sorm2r('Left', 'Transpose' , ncv , +- & 1 , nconv , workl(iq) , +- & ldq , workl(iw+ncv), workl(ihb), +- & ncv , temp , ierr) +-c +-c %-----------------------------------------------------% +-c | Make a copy of the last row into | +-c | workl(iw+ncv:iw+2*ncv), as it is needed again in | +-c | the Ritz vector purification step below | +-c %-----------------------------------------------------% +-c +- do 67 j = 1, nconv +- workl(iw+ncv+j-1) = workl(ihb+j-1) +- 67 continue +- +- else if (rvec .and. howmny .eq. 'S') then +-c +-c Not yet implemented. See remark 2 above. +-c +- end if +-c +- if (type .eq. 'REGULR' .and. rvec) then +-c +- do 70 j=1, ncv +- workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) +- 70 continue +-c +- else if (type .ne. 'REGULR' .and. rvec) then +-c +-c %-------------------------------------------------% +-c | * Determine Ritz estimates of the theta. | +-c | If RVEC = .true. then compute Ritz estimates | +-c | of the theta. | +-c | If RVEC = .false. then copy Ritz estimates | +-c | as computed by ssaupd. | +-c | * Determine Ritz estimates of the lambda. | +-c %-------------------------------------------------% +-c +- call sscal (ncv, bnorm2, workl(ihb), 1) +- if (type .eq. 'SHIFTI') then +-c +- do 80 k=1, ncv +- workl(ihb+k-1) = abs( workl(ihb+k-1) ) +- & / workl(iw+k-1)**2 +- 80 continue +-c +- else if (type .eq. 'BUCKLE') then +-c +- do 90 k=1, ncv +- workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) +- & / (workl(iw+k-1)-one )**2 +- 90 continue +-c +- else if (type .eq. 'CAYLEY') then +-c +- do 100 k=1, ncv +- workl(ihb+k-1) = abs( workl(ihb+k-1) +- & / workl(iw+k-1)*(workl(iw+k-1)-one) ) +- 100 continue +-c +- end if +-c +- end if +-c +- if (type .ne. 'REGULR' .and. msglvl .gt. 1) then +- call svout(logfil, nconv, d, ndigit, +- & '_seupd: Untransformed converged Ritz values') +- call svout(logfil, nconv, workl(ihb), ndigit, +- & '_seupd: Ritz estimates of the untransformed Ritz values') +- else if (msglvl .gt. 1) then +- call svout(logfil, nconv, d, ndigit, +- & '_seupd: Converged Ritz values') +- call svout(logfil, nconv, workl(ihb), ndigit, +- & '_seupd: Associated Ritz estimates') +- end if +-c +-c %-------------------------------------------------% +-c | Ritz vector purification step. Formally perform | +-c | one of inverse subspace iteration. Only used | +-c | for MODE = 3,4,5. See reference 7 | +-c %-------------------------------------------------% +-c +- if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then +-c +- do 110 k=0, nconv-1 +- workl(iw+k) = workl(iw+ncv+k) +- & / workl(iw+k) +- 110 continue +-c +- else if (rvec .and. type .eq. 'BUCKLE') then +-c +- do 120 k=0, nconv-1 +- workl(iw+k) = workl(iw+ncv+k) +- & / (workl(iw+k)-one) +- 120 continue +-c +- end if +-c +- if (type .ne. 'REGULR') +- & call sger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of sseupd| +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssgets.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssgets.f +deleted file mode 100644 +index f40ca76a8a..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssgets.f ++++ /dev/null +@@ -1,219 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssgets +-c +-c\Description: +-c Given the eigenvalues of the symmetric tridiagonal matrix H, +-c computes the NP shifts AMU that are zeros of the polynomial of +-c degree NP which filters out components of the unwanted eigenvectors +-c corresponding to the AMU's based on some given criteria. +-c +-c NOTE: This is called even in the case of user specified shifts in +-c order to sort the eigenvalues, and error bounds of H for later use. +-c +-c\Usage: +-c call ssgets +-c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) +-c +-c\Arguments +-c ISHIFT Integer. (INPUT) +-c Method for selecting the implicit shifts at each iteration. +-c ISHIFT = 0: user specified shifts +-c ISHIFT = 1: exact shift with respect to the matrix H. +-c +-c WHICH Character*2. (INPUT) +-c Shift selection criteria. +-c 'LM' -> KEV eigenvalues of largest magnitude are retained. +-c 'SM' -> KEV eigenvalues of smallest magnitude are retained. +-c 'LA' -> KEV eigenvalues of largest value are retained. +-c 'SA' -> KEV eigenvalues of smallest value are retained. +-c 'BE' -> KEV eigenvalues, half from each end of the spectrum. +-c If KEV is odd, compute one more from the high end. +-c +-c KEV Integer. (INPUT) +-c KEV+NP is the size of the matrix H. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be computed. +-c +-c RITZ Real array of length KEV+NP. (INPUT/OUTPUT) +-c On INPUT, RITZ contains the eigenvalues of H. +-c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues +-c are in the first NP locations and the wanted part is in +-c the last KEV locations. When exact shifts are selected, the +-c unwanted part corresponds to the shifts to be applied. +-c +-c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) +-c Error bounds corresponding to the ordering in RITZ. +-c +-c SHIFTS Real array of length NP. (INPUT/OUTPUT) +-c On INPUT: contains the user specified shifts if ISHIFT = 0. +-c On OUTPUT: contains the shifts sorted into decreasing order +-c of magnitude with respect to the Ritz estimates contained in +-c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c ssortr ARPACK utility sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c svout ARPACK utility routine that prints vectors. +-c scopy Level 1 BLAS that copies one vector to another. +-c sswap Level 1 BLAS that swaps the contents of two vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/93: Version ' 2.1' +-c +-c\SCCS Information: @(#) +-c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\Remarks +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssgets ( ishift, which, kev, np, ritz, bounds, shifts ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- integer ishift, kev, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & bounds(kev+np), ritz(kev+np), shifts(np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Real +- & one, zero +- parameter (one = 1.0E+0, zero = 0.0E+0) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer kevd2, msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external sswap, scopy, ssortr, arscnd +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic max, min +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = msgets +-c +- if (which .eq. 'BE') then +-c +-c %-----------------------------------------------------% +-c | Both ends of the spectrum are requested. | +-c | Sort the eigenvalues into algebraically increasing | +-c | order first then swap high end of the spectrum next | +-c | to low end in appropriate locations. | +-c | NOTE: when np < floor(kev/2) be careful not to swap | +-c | overlapping locations. | +-c %-----------------------------------------------------% +-c +- call ssortr ('LA', .true., kev+np, ritz, bounds) +- kevd2 = kev / 2 +- if ( kev .gt. 1 ) then +- call sswap ( min(kevd2,np), ritz, 1, +- & ritz( max(kevd2,np)+1 ), 1) +- call sswap ( min(kevd2,np), bounds, 1, +- & bounds( max(kevd2,np)+1 ), 1) +- end if +-c +- else +-c +-c %----------------------------------------------------% +-c | LM, SM, LA, SA case. | +-c | Sort the eigenvalues of H into the desired order | +-c | and apply the resulting order to BOUNDS. | +-c | The eigenvalues are sorted so that the wanted part | +-c | are always in the last KEV locations. | +-c %----------------------------------------------------% +-c +- call ssortr (which, .true., kev+np, ritz, bounds) +- end if +-c +- if (ishift .eq. 1 .and. np .gt. 0) then +-c +-c %-------------------------------------------------------% +-c | Sort the unwanted Ritz values used as shifts so that | +-c | the ones with largest Ritz estimates are first. | +-c | This will tend to minimize the effects of the | +-c | forward instability of the iteration when the shifts | +-c | are applied in subroutine ssapps. | +-c %-------------------------------------------------------% +-c +- call ssortr ('SM', .true., np, bounds, ritz) +- call scopy (np, ritz, 1, shifts, 1) +- end if +-c +- call arscnd (t1) +- tsgets = tsgets + (t1 - t0) +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [kev], ndigit, '_sgets: KEV is') +- call ivout (logfil, 1, [np], ndigit, '_sgets: NP is') +- call svout (logfil, kev+np, ritz, ndigit, +- & '_sgets: Eigenvalues of current H matrix') +- call svout (logfil, kev+np, bounds, ndigit, +- & '_sgets: Associated Ritz estimates') +- end if +-c +- return +-c +-c %---------------% +-c | End of ssgets | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortc.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortc.f +deleted file mode 100644 +index e322039cdd..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortc.f ++++ /dev/null +@@ -1,344 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssortc +-c +-c\Description: +-c Sorts the complex array in XREAL and XIMAG into the order +-c specified by WHICH and optionally applies the permutation to the +-c real array Y. It is assumed that if an element of XIMAG is +-c nonzero, then its negative is also an element. In other words, +-c both members of a complex conjugate pair are to be sorted and the +-c pairs are kept adjacent to each other. +-c +-c\Usage: +-c call ssortc +-c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. +-c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. +-c 'LR' -> sort XREAL into increasing order of algebraic. +-c 'SR' -> sort XREAL into decreasing order of algebraic. +-c 'LI' -> sort XIMAG into increasing order of magnitude. +-c 'SI' -> sort XIMAG into decreasing order of magnitude. +-c NOTE: If an element of XIMAG is non-zero, then its negative +-c is also an element. +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to array Y. +-c APPLY = .FALSE. -> do not apply the sorted order to array Y. +-c +-c N Integer. (INPUT) +-c Size of the arrays. +-c +-c XREAL, Real array of length N. (INPUT/OUTPUT) +-c XIMAG Real and imaginary part of the array to be sorted. +-c +-c Y Real array of length N. (INPUT/OUTPUT) +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c xx/xx/92: Version ' 2.1' +-c Adapted from the sort routine in LANSO. +-c +-c\SCCS Information: @(#) +-c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssortc (which, apply, n, xreal, ximag, y) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & xreal(0:n-1), ximag(0:n-1), y(0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Real +- & temp, temp1, temp2 +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Real +- & slapy2 +- external slapy2 +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'LM') then +-c +-c %------------------------------------------------------% +-c | Sort XREAL,XIMAG into increasing order of magnitude. | +-c %------------------------------------------------------% +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +-c +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- temp1 = slapy2(xreal(j),ximag(j)) +- temp2 = slapy2(xreal(j+igap),ximag(j+igap)) +-c +- if (temp1.gt.temp2) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 30 +- end if +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c %------------------------------------------------------% +-c | Sort XREAL,XIMAG into decreasing order of magnitude. | +-c %------------------------------------------------------% +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +-c +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j .lt. 0) go to 60 +-c +- temp1 = slapy2(xreal(j),ximag(j)) +- temp2 = slapy2(xreal(j+igap),ximag(j+igap)) +-c +- if (temp1.lt.temp2) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into increasing order of algebraic. | +-c %------------------------------------------------% +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +-c +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (xreal(j).gt.xreal(j+igap)) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'SR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into decreasing order of algebraic. | +-c %------------------------------------------------% +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (xreal(j).lt.xreal(j+igap)) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +-c +- else if (which .eq. 'LI') then +-c +-c %------------------------------------------------% +-c | Sort XIMAG into increasing order of magnitude. | +-c %------------------------------------------------% +-c +- 130 continue +- if (igap .eq. 0) go to 9000 +- do 150 i = igap, n-1 +- j = i-igap +- 140 continue +-c +- if (j.lt.0) go to 150 +-c +- if (abs(ximag(j)).gt.abs(ximag(j+igap))) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 150 +- endif +- j = j-igap +- go to 140 +- 150 continue +- igap = igap / 2 +- go to 130 +-c +- else if (which .eq. 'SI') then +-c +-c %------------------------------------------------% +-c | Sort XIMAG into decreasing order of magnitude. | +-c %------------------------------------------------% +-c +- 160 continue +- if (igap .eq. 0) go to 9000 +- do 180 i = igap, n-1 +- j = i-igap +- 170 continue +-c +- if (j.lt.0) go to 180 +-c +- if (abs(ximag(j)).lt.abs(ximag(j+igap))) then +- temp = xreal(j) +- xreal(j) = xreal(j+igap) +- xreal(j+igap) = temp +-c +- temp = ximag(j) +- ximag(j) = ximag(j+igap) +- ximag(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 180 +- endif +- j = j-igap +- go to 170 +- 180 continue +- igap = igap / 2 +- go to 160 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of ssortc | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortr.f +deleted file mode 100644 +index 25d324b657..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/ssortr.f ++++ /dev/null +@@ -1,218 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: ssortr +-c +-c\Description: +-c Sort the array X1 in the order specified by WHICH and optionally +-c applies the permutation to the array X2. +-c +-c\Usage: +-c call ssortr +-c ( WHICH, APPLY, N, X1, X2 ) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> X1 is sorted into increasing order of magnitude. +-c 'SM' -> X1 is sorted into decreasing order of magnitude. +-c 'LA' -> X1 is sorted into increasing order of algebraic. +-c 'SA' -> X1 is sorted into decreasing order of algebraic. +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to X2. +-c APPLY = .FALSE. -> do not apply the sorted order to X2. +-c +-c N Integer. (INPUT) +-c Size of the arrays. +-c +-c X1 Real array of length N. (INPUT/OUTPUT) +-c The array to be sorted. +-c +-c X2 Real array of length N. (INPUT/OUTPUT) +-c Only referenced if APPLY = .TRUE. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\Revision history: +-c 12/16/93: Version ' 2.1'. +-c Adapted from the sort routine in LANSO. +-c +-c\SCCS Information: @(#) +-c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine ssortr (which, apply, n, x1, x2) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & x1(0:n-1), x2(0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Real +- & temp +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'SA') then +-c +-c X1 is sorted into decreasing order of algebraic. +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- if (x1(j).lt.x1(j+igap)) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 30 +- endif +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c X1 is sorted into decreasing order of magnitude. +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j.lt.0) go to 60 +-c +- if (abs(x1(j)).lt.abs(x1(j+igap))) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LA') then +-c +-c X1 is sorted into increasing order of algebraic. +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (x1(j).gt.x1(j+igap)) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'LM') then +-c +-c X1 is sorted into increasing order of magnitude. +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (abs(x1(j)).gt.abs(x1(j+igap))) then +- temp = x1(j) +- x1(j) = x1(j+igap) +- x1(j+igap) = temp +- if (apply) then +- temp = x2(j) +- x2(j) = x2(j+igap) +- x2(j+igap) = temp +- end if +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of ssortr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstatn.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstatn.f +deleted file mode 100644 +index f3288c1aba..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstatn.f ++++ /dev/null +@@ -1,61 +0,0 @@ +-c +-c %---------------------------------------------% +-c | Initialize statistic and timing information | +-c | for nonsymmetric Arnoldi code. | +-c %---------------------------------------------% +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 +-c +- subroutine sstatn +-c +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +-c +- include 'stat.h' +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- nopx = 0 +- nbx = 0 +- nrorth = 0 +- nitref = 0 +- nrstrt = 0 +-c +- tnaupd = 0.0E+0 +- tnaup2 = 0.0E+0 +- tnaitr = 0.0E+0 +- tneigh = 0.0E+0 +- tngets = 0.0E+0 +- tnapps = 0.0E+0 +- tnconv = 0.0E+0 +- titref = 0.0E+0 +- tgetv0 = 0.0E+0 +- trvec = 0.0E+0 +-c +-c %----------------------------------------------------% +-c | User time including reverse communication overhead | +-c %----------------------------------------------------% +-c +- tmvopx = 0.0E+0 +- tmvbx = 0.0E+0 +-c +- return +-c +-c +-c %---------------% +-c | End of sstatn | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstats.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstats.f +deleted file mode 100644 +index 0822d3f3aa..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstats.f ++++ /dev/null +@@ -1,47 +0,0 @@ +-c +-c\SCCS Information: @(#) +-c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 +-c %---------------------------------------------% +-c | Initialize statistic and timing information | +-c | for symmetric Arnoldi code. | +-c %---------------------------------------------% +- +- subroutine sstats +- +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +- include 'stat.h' +- +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +- +- nopx = 0 +- nbx = 0 +- nrorth = 0 +- nitref = 0 +- nrstrt = 0 +- +- tsaupd = 0.0E+0 +- tsaup2 = 0.0E+0 +- tsaitr = 0.0E+0 +- tseigt = 0.0E+0 +- tsgets = 0.0E+0 +- tsapps = 0.0E+0 +- tsconv = 0.0E+0 +- titref = 0.0E+0 +- tgetv0 = 0.0E+0 +- trvec = 0.0E+0 +- +-c %----------------------------------------------------% +-c | User time including reverse communication overhead | +-c %----------------------------------------------------% +- tmvopx = 0.0E+0 +- tmvbx = 0.0E+0 +- +- return +-c +-c End of sstats +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstqrb.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstqrb.f +deleted file mode 100644 +index 9697c36602..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/sstqrb.f ++++ /dev/null +@@ -1,594 +0,0 @@ +-c----------------------------------------------------------------------- +-c\BeginDoc +-c +-c\Name: sstqrb +-c +-c\Description: +-c Computes all eigenvalues and the last component of the eigenvectors +-c of a symmetric tridiagonal matrix using the implicit QL or QR method. +-c +-c This is mostly a modification of the LAPACK routine ssteqr. +-c See Remarks. +-c +-c\Usage: +-c call sstqrb +-c ( N, D, E, Z, WORK, INFO ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c The number of rows and columns in the matrix. N >= 0. +-c +-c D Real array, dimension (N). (INPUT/OUTPUT) +-c On entry, D contains the diagonal elements of the +-c tridiagonal matrix. +-c On exit, D contains the eigenvalues, in ascending order. +-c If an error exit is made, the eigenvalues are correct +-c for indices 1,2,...,INFO-1, but they are unordered and +-c may not be the smallest eigenvalues of the matrix. +-c +-c E Real array, dimension (N-1). (INPUT/OUTPUT) +-c On entry, E contains the subdiagonal elements of the +-c tridiagonal matrix in positions 1 through N-1. +-c On exit, E has been destroyed. +-c +-c Z Real array, dimension (N). (OUTPUT) +-c On exit, Z contains the last row of the orthonormal +-c eigenvector matrix of the symmetric tridiagonal matrix. +-c If an error exit is made, Z contains the last row of the +-c eigenvector matrix associated with the stored eigenvalues. +-c +-c WORK Real array, dimension (max(1,2*N-2)). (WORKSPACE) +-c Workspace used in accumulating the transformation for +-c computing the last components of the eigenvectors. +-c +-c INFO Integer. (OUTPUT) +-c = 0: normal return. +-c < 0: if INFO = -i, the i-th argument had an illegal value. +-c > 0: if INFO = +i, the i-th eigenvalue has not converged +-c after a total of 30*N iterations. +-c +-c\Remarks +-c 1. None. +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx real +-c +-c\Routines called: +-c saxpy Level 1 BLAS that computes a vector triad. +-c scopy Level 1 BLAS that copies one vector to another. +-c sswap Level 1 BLAS that swaps the contents of two vectors. +-c lsame LAPACK character comparison routine. +-c slae2 LAPACK routine that computes the eigenvalues of a 2-by-2 +-c symmetric matrix. +-c slaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric +-c matrix. +-c slamch LAPACK routine that determines machine constants. +-c slanst LAPACK routine that computes the norm of a matrix. +-c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c slartg LAPACK Givens rotation construction routine. +-c slascl LAPACK routine for careful scaling of a matrix. +-c slaset LAPACK matrix initialization routine. +-c slasr LAPACK routine that applies an orthogonal transformation to +-c a matrix. +-c slasrt LAPACK sorting routine. +-c ssteqr LAPACK routine that computes eigenvalues and eigenvectors +-c of a symmetric tridiagonal matrix. +-c xerbla LAPACK error handler routine. +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c 1. Starting with version 2.5, this routine is a modified version +-c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, +-c only commented out and new lines inserted. +-c All lines commented out have "c$$$" at the beginning. +-c Note that the LAPACK version 1.0 subroutine SSTEQR contained +-c bugs. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine sstqrb ( n, d, e, z, work, info ) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer info, n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Real +- & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) +-c +-c .. parameters .. +- Real +- & zero, one, two, three +- parameter ( zero = 0.0E+0, one = 1.0E+0, +- & two = 2.0E+0, three = 3.0E+0 ) +- integer maxit +- parameter ( maxit = 30 ) +-c .. +-c .. local scalars .. +- integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, +- & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, +- & nm1, nmaxit +- Real +- & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, +- & s, safmax, safmin, ssfmax, ssfmin, tst +-c .. +-c .. external functions .. +- logical lsame +- Real +- & slamch, slanst, slapy2 +- external lsame, slamch, slanst, slapy2 +-c .. +-c .. external subroutines .. +- external slae2, slaev2, slartg, slascl, slaset, slasr, +- & slasrt, sswap, xerbla +-c .. +-c .. intrinsic functions .. +- intrinsic abs, max, sign, sqrt +-c .. +-c .. executable statements .. +-c +-c test the input parameters. +-c +- info = 0 +-c +-c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN +-c$$$ ICOMPZ = 0 +-c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN +-c$$$ ICOMPZ = 1 +-c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN +-c$$$ ICOMPZ = 2 +-c$$$ ELSE +-c$$$ ICOMPZ = -1 +-c$$$ END IF +-c$$$ IF( ICOMPZ.LT.0 ) THEN +-c$$$ INFO = -1 +-c$$$ ELSE IF( N.LT.0 ) THEN +-c$$$ INFO = -2 +-c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, +-c$$$ $ N ) ) ) THEN +-c$$$ INFO = -6 +-c$$$ END IF +-c$$$ IF( INFO.NE.0 ) THEN +-c$$$ CALL XERBLA( 'SSTEQR', -INFO ) +-c$$$ RETURN +-c$$$ END IF +-c +-c *** New starting with version 2.5 *** +-c +- icompz = 2 +-c ************************************* +-c +-c quick return if possible +-c +- if( n.eq.0 ) +- $ return +-c +- if( n.eq.1 ) then +- if( icompz.eq.2 ) z( 1 ) = one +- return +- end if +-c +-c determine the unit roundoff and over/underflow thresholds. +-c +- eps = slamch( 'e' ) +- eps2 = eps**2 +- safmin = slamch( 's' ) +- safmax = one / safmin +- ssfmax = sqrt( safmax ) / three +- ssfmin = sqrt( safmin ) / eps2 +-c +-c compute the eigenvalues and eigenvectors of the tridiagonal +-c matrix. +-c +-c$$ if( icompz.eq.2 ) +-c$$$ $ call slaset( 'full', n, n, zero, one, z, ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- if ( icompz .eq. 2 ) then +- do 5 j = 1, n-1 +- z(j) = zero +- 5 continue +- z( n ) = one +- end if +-c ************************************* +-c +- nmaxit = n*maxit +- jtot = 0 +-c +-c determine where the matrix splits and choose ql or qr iteration +-c for each block, according to whether top or bottom diagonal +-c element is smaller. +-c +- l1 = 1 +- nm1 = n - 1 +-c +- 10 continue +- if( l1.gt.n ) +- $ go to 160 +- if( l1.gt.1 ) +- $ e( l1-1 ) = zero +- if( l1.le.nm1 ) then +- do 20 m = l1, nm1 +- tst = abs( e( m ) ) +- if( tst.eq.zero ) +- $ go to 30 +- if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ +- $ 1 ) ) ) )*eps ) then +- e( m ) = zero +- go to 30 +- end if +- 20 continue +- end if +- m = n +-c +- 30 continue +- l = l1 +- lsv = l +- lend = m +- lendsv = lend +- l1 = m + 1 +- if( lend.eq.l ) +- $ go to 10 +-c +-c scale submatrix in rows and columns l to lend +-c +- anorm = slanst( 'i', lend-l+1, d( l ), e( l ) ) +- iscale = 0 +- if( anorm.eq.zero ) +- $ go to 10 +- if( anorm.gt.ssfmax ) then +- iscale = 1 +- call slascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, +- $ info ) +- call slascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, +- $ info ) +- else if( anorm.lt.ssfmin ) then +- iscale = 2 +- call slascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, +- $ info ) +- call slascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, +- $ info ) +- end if +-c +-c choose between ql and qr iteration +-c +- if( abs( d( lend ) ).lt.abs( d( l ) ) ) then +- lend = lsv +- l = lendsv +- end if +-c +- if( lend.gt.l ) then +-c +-c ql iteration +-c +-c look for small subdiagonal element. +-c +- 40 continue +- if( l.ne.lend ) then +- lendm1 = lend - 1 +- do 50 m = l, lendm1 +- tst = abs( e( m ) )**2 +- if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ +- $ safmin )go to 60 +- 50 continue +- end if +-c +- m = lend +-c +- 60 continue +- if( m.lt.lend ) +- $ e( m ) = zero +- p = d( l ) +- if( m.eq.l ) +- $ go to 80 +-c +-c if remaining matrix is 2-by-2, use slae2 or slaev2 +-c to compute its eigensystem. +-c +- if( m.eq.l+1 ) then +- if( icompz.gt.0 ) then +- call slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) +- work( l ) = c +- work( n-1+l ) = s +-c$$$ call slasr( 'r', 'v', 'b', n, 2, work( l ), +-c$$$ $ work( n-1+l ), z( 1, l ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- tst = z(l+1) +- z(l+1) = c*tst - s*z(l) +- z(l) = s*tst + c*z(l) +-c ************************************* +- else +- call slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) +- end if +- d( l ) = rt1 +- d( l+1 ) = rt2 +- e( l ) = zero +- l = l + 2 +- if( l.le.lend ) +- $ go to 40 +- go to 140 +- end if +-c +- if( jtot.eq.nmaxit ) +- $ go to 140 +- jtot = jtot + 1 +-c +-c form shift. +-c +- g = ( d( l+1 )-p ) / ( two*e( l ) ) +- r = slapy2( g, one ) +- g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) +-c +- s = one +- c = one +- p = zero +-c +-c inner loop +-c +- mm1 = m - 1 +- do 70 i = mm1, l, -1 +- f = s*e( i ) +- b = c*e( i ) +- call slartg( g, f, c, s, r ) +- if( i.ne.m-1 ) +- $ e( i+1 ) = r +- g = d( i+1 ) - p +- r = ( d( i )-g )*s + two*c*b +- p = s*r +- d( i+1 ) = g + p +- g = c*r - b +-c +-c if eigenvectors are desired, then save rotations. +-c +- if( icompz.gt.0 ) then +- work( i ) = c +- work( n-1+i ) = -s +- end if +-c +- 70 continue +-c +-c if eigenvectors are desired, then apply saved rotations. +-c +- if( icompz.gt.0 ) then +- mm = m - l + 1 +-c$$$ call slasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), +-c$$$ $ z( 1, l ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- call slasr( 'r', 'v', 'b', 1, mm, work( l ), +- & work( n-1+l ), z( l ), 1 ) +-c ************************************* +- end if +-c +- d( l ) = d( l ) - p +- e( l ) = g +- go to 40 +-c +-c eigenvalue found. +-c +- 80 continue +- d( l ) = p +-c +- l = l + 1 +- if( l.le.lend ) +- $ go to 40 +- go to 140 +-c +- else +-c +-c qr iteration +-c +-c look for small superdiagonal element. +-c +- 90 continue +- if( l.ne.lend ) then +- lendp1 = lend + 1 +- do 100 m = l, lendp1, -1 +- tst = abs( e( m-1 ) )**2 +- if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ +- $ safmin )go to 110 +- 100 continue +- end if +-c +- m = lend +-c +- 110 continue +- if( m.gt.lend ) +- $ e( m-1 ) = zero +- p = d( l ) +- if( m.eq.l ) +- $ go to 130 +-c +-c if remaining matrix is 2-by-2, use slae2 or slaev2 +-c to compute its eigensystem. +-c +- if( m.eq.l-1 ) then +- if( icompz.gt.0 ) then +- call slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) +-c$$$ work( m ) = c +-c$$$ work( n-1+m ) = s +-c$$$ call slasr( 'r', 'v', 'f', n, 2, work( m ), +-c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- tst = z(l) +- z(l) = c*tst - s*z(l-1) +- z(l-1) = s*tst + c*z(l-1) +-c ************************************* +- else +- call slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) +- end if +- d( l-1 ) = rt1 +- d( l ) = rt2 +- e( l-1 ) = zero +- l = l - 2 +- if( l.ge.lend ) +- $ go to 90 +- go to 140 +- end if +-c +- if( jtot.eq.nmaxit ) +- $ go to 140 +- jtot = jtot + 1 +-c +-c form shift. +-c +- g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) +- r = slapy2( g, one ) +- g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) +-c +- s = one +- c = one +- p = zero +-c +-c inner loop +-c +- lm1 = l - 1 +- do 120 i = m, lm1 +- f = s*e( i ) +- b = c*e( i ) +- call slartg( g, f, c, s, r ) +- if( i.ne.m ) +- $ e( i-1 ) = r +- g = d( i ) - p +- r = ( d( i+1 )-g )*s + two*c*b +- p = s*r +- d( i ) = g + p +- g = c*r - b +-c +-c if eigenvectors are desired, then save rotations. +-c +- if( icompz.gt.0 ) then +- work( i ) = c +- work( n-1+i ) = s +- end if +-c +- 120 continue +-c +-c if eigenvectors are desired, then apply saved rotations. +-c +- if( icompz.gt.0 ) then +- mm = l - m + 1 +-c$$$ call slasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), +-c$$$ $ z( 1, m ), ldz ) +-c +-c *** New starting with version 2.5 *** +-c +- call slasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), +- & z( m ), 1 ) +-c ************************************* +- end if +-c +- d( l ) = d( l ) - p +- e( lm1 ) = g +- go to 90 +-c +-c eigenvalue found. +-c +- 130 continue +- d( l ) = p +-c +- l = l - 1 +- if( l.ge.lend ) +- $ go to 90 +- go to 140 +-c +- end if +-c +-c undo scaling if necessary +-c +- 140 continue +- if( iscale.eq.1 ) then +- call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, +- $ d( lsv ), n, info ) +- call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), +- $ n, info ) +- else if( iscale.eq.2 ) then +- call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, +- $ d( lsv ), n, info ) +- call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), +- $ n, info ) +- end if +-c +-c check for no convergence to an eigenvalue after a total +-c of n*maxit iterations. +-c +- if( jtot.lt.nmaxit ) +- $ go to 10 +- do 150 i = 1, n - 1 +- if( e( i ).ne.zero ) +- $ info = info + 1 +- 150 continue +- go to 190 +-c +-c order eigenvalues and eigenvectors. +-c +- 160 continue +- if( icompz.eq.0 ) then +-c +-c use quick sort +-c +- call slasrt( 'i', n, d, info ) +-c +- else +-c +-c use selection sort to minimize swaps of eigenvectors +-c +- do 180 ii = 2, n +- i = ii - 1 +- k = i +- p = d( i ) +- do 170 j = ii, n +- if( d( j ).lt.p ) then +- k = j +- p = d( j ) +- end if +- 170 continue +- if( k.ne.i ) then +- d( k ) = d( i ) +- d( i ) = p +-c$$$ call sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) +-c *** New starting with version 2.5 *** +-c +- p = z(k) +- z(k) = z(i) +- z(i) = p +-c ************************************* +- end if +- 180 continue +- end if +-c +- 190 continue +- return +-c +-c %---------------% +-c | End of sstqrb | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/stat.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/stat.h +deleted file mode 100644 +index 81d49c3bd2..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/stat.h ++++ /dev/null +@@ -1,21 +0,0 @@ +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +-c +-c\SCCS Information: @(#) +-c FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 +-c +-c real t0, t1, t2, t3, t4, t5 +-c save t0, t1, t2, t3, t4, t5 +-c +-c integer nopx, nbx, nrorth, nitref, nrstrt +-c real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, +-c & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, +-c & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, +-c & tmvopx, tmvbx, tgetv0, titref, trvec +-c common /timing/ +-c & nopx, nbx, nrorth, nitref, nrstrt, +-c & tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, +-c & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, +-c & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, +-c & tmvopx, tmvbx, tgetv0, titref, trvec +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/version.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/version.h +deleted file mode 100644 +index ecdd9b3405..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/version.h ++++ /dev/null +@@ -1,30 +0,0 @@ +-/* +- +- In the current version, the parameter KAPPA in the Kahan's test +- for orthogonality is set to 0.717, the same as used by Gragg & Reichel. +- However computational experience indicates that this is a little too +- strict and will frequently force reorthogonalization when it is not +- necessary to do so. +- +- Also the "moving boundary" idea is not currently activated in the nonsymmetric +- code since it is not conclusive that it's the right thing to do all the time. +- Requires further investigation. +- +- As of 02/01/93 Richard Lehoucq assumes software control of the codes from +- Phuong Vu. On 03/01/93 all the *.F files were migrated SCCS. The 1.1 version +- of codes are those received from Phuong Vu. The frozen version of 07/08/92 +- is now considered version 1.1. +- +- Version 2.1 contains two new symmetric routines, sesrt and seupd. +- Changes as well as bug fixes for version 1.1 codes that were only corrected +- for programming bugs are version 1.2. These 1.2 versions will also be in version 2.1. +- Subroutine [d,s]saupd now requires slightly more workspace. See [d,s]saupd for the +- details. +- +- \SCCS Information: @(#) +- FILE: version.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 +- +- */ +- +-#define VERSION_NUMBER ' 2.1' +-#define VERSION_DATE ' 11/15/95' +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zgetv0.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zgetv0.f +deleted file mode 100644 +index 1fbd508519..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zgetv0.f ++++ /dev/null +@@ -1,416 +0,0 @@ +-c\BeginDoc +-c +-c\Name: zgetv0 +-c +-c\Description: +-c Generate a random initial residual vector for the Arnoldi process. +-c Force the residual vector to be in the range of the operator OP. +-c +-c\Usage: +-c call zgetv0 +-c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, +-c IPNTR, WORKD, IERR ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to zgetv0. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B in the (generalized) +-c eigenvalue problem A*x = lambda*B*x. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x +-c +-c ITRY Integer. (INPUT) +-c ITRY counts the number of times that zgetv0 is called. +-c It should be set to 1 on the initial call to zgetv0. +-c +-c INITV Logical variable. (INPUT) +-c .TRUE. => the initial residual vector is given in RESID. +-c .FALSE. => generate a random initial residual vector. +-c +-c N Integer. (INPUT) +-c Dimension of the problem. +-c +-c J Integer. (INPUT) +-c Index of the residual vector to be generated, with respect to +-c the Arnoldi process. J > 1 in case of a "restart". +-c +-c V Complex*16 N by J array. (INPUT) +-c The first J-1 columns of V contain the current Arnoldi basis +-c if this is a "restart". +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c RESID Complex*16 array of length N. (INPUT/OUTPUT) +-c Initial residual vector to be generated. If RESID is +-c provided, force RESID into the range of the operator OP. +-c +-c RNORM Double precision scalar. (OUTPUT) +-c B-norm of the generated residual. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c +-c WORKD Complex*16 work array of length 2*N. (REVERSE COMMUNICATION). +-c On exit, WORK(1:N) = B*RESID to be used in SSAITR. +-c +-c IERR Integer. (OUTPUT) +-c = 0: Normal exit. +-c = -1: Cannot generate a nontrivial restarted residual vector +-c in the range of the operator OP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c +-c\Routines called: +-c arscnd ARPACK utility routine for timing. +-c zvout ARPACK utility routine that prints vectors. +-c zlarnv LAPACK routine for generating a random vector. +-c zgemv Level 2 BLAS routine for matrix vector multiplication. +-c zcopy Level 1 BLAS that copies one vector to another. +-c zdotc Level 1 BLAS that computes the scalar product of two vectors. +-c dznrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine zgetv0 +- & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, +- & ipntr, workd, ierr ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- logical initv +- integer ido, ierr, itry, j, ldv, n +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Complex*16 +- & resid(n), v(ldv,j), workd(2*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- Double precision +- & rzero +- parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), +- & rzero = 0.0D+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical first, inits, orth +- integer idist, iseed(4), iter, msglvl, jj +- Double precision +- & rnorm0 +- Complex*16 +- & cnorm +- save first, iseed, inits, iter, msglvl, orth, rnorm0 +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zcopy, zgemv, zlarnv, zvout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dznrm2, dlapy2 +- Complex*16 +- & zzdotc +- external zzdotc, dznrm2, dlapy2 +-c +-c %-----------------% +-c | Data Statements | +-c %-----------------% +-c +- data inits /.true./ +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c +-c %-----------------------------------% +-c | Initialize the seed of the LAPACK | +-c | random number generator | +-c %-----------------------------------% +-c +- if (inits) then +- iseed(1) = 1 +- iseed(2) = 3 +- iseed(3) = 5 +- iseed(4) = 7 +- inits = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mgetv0 +-c +- ierr = 0 +- iter = 0 +- first = .FALSE. +- orth = .FALSE. +-c +-c %-----------------------------------------------------% +-c | Possibly generate a random starting vector in RESID | +-c | Use a LAPACK random number generator used by the | +-c | matrix generation routines. | +-c | idist = 1: uniform (0,1) distribution; | +-c | idist = 2: uniform (-1,1) distribution; | +-c | idist = 3: normal (0,1) distribution; | +-c %-----------------------------------------------------% +-c +- if (.not.initv) then +- idist = 2 +- call zlarnv (idist, iseed, n, resid) +- end if +-c +-c %----------------------------------------------------------% +-c | Force the starting vector into the range of OP to handle | +-c | the generalized problem when B is possibly (singular). | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (itry .eq. 1) then +- nopx = nopx + 1 +- ipntr(1) = 1 +- ipntr(2) = n + 1 +- call zcopy (n, resid, 1, workd, 1) +- ido = -1 +- go to 9000 +- else if (itry .gt. 1 .and. bmat .eq. 'G') then +- call zcopy (n, resid, 1, workd(n + 1), 1) +- end if +- end if +-c +-c %----------------------------------------% +-c | Back from computing OP*(initial-vector) | +-c %----------------------------------------% +-c +- if (first) go to 20 +-c +-c %-----------------------------------------------% +-c | Back from computing OP*(orthogonalized-vector) | +-c %-----------------------------------------------% +-c +- if (orth) go to 40 +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +-c +-c %------------------------------------------------------% +-c | Starting vector is now in the range of OP; r = OP*r; | +-c | Compute B-norm of starting vector. | +-c %------------------------------------------------------% +-c +- call arscnd (t2) +- first = .TRUE. +- if (itry .eq. 1) call zcopy (n, workd(n + 1), 1, resid, 1) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call zcopy (n, resid, 1, workd, 1) +- end if +-c +- 20 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- first = .FALSE. +- if (bmat .eq. 'G') then +- cnorm = zzdotc (n, resid, 1, workd, 1) +- rnorm0 = sqrt(dlapy2(dble(cnorm),aimag(cnorm))) +- else if (bmat .eq. 'I') then +- rnorm0 = dznrm2(n, resid, 1) +- end if +- rnorm = rnorm0 +-c +-c %---------------------------------------------% +-c | Exit if this is the very first Arnoldi step | +-c %---------------------------------------------% +-c +- if (j .eq. 1) go to 50 +-c +-c %---------------------------------------------------------------- +-c | Otherwise need to B-orthogonalize the starting vector against | +-c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | +-c | This is the case where an invariant subspace is encountered | +-c | in the middle of the Arnoldi factorization. | +-c | | +-c | s = V^{T}*B*r; r = r - V*s; | +-c | | +-c | Stopping criteria used for iter. ref. is discussed in | +-c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | +-c %---------------------------------------------------------------% +-c +- orth = .TRUE. +- 30 continue +-c +- call zgemv ('C', n, j-1, one, v, ldv, workd, 1, +- & zero, workd(n+1), 1) +- call zgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, +- & one, resid, 1) +-c +-c %----------------------------------------------------------% +-c | Compute the B-norm of the orthogonalized starting vector | +-c %----------------------------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call zcopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +- go to 9000 +- else if (bmat .eq. 'I') then +- call zcopy (n, resid, 1, workd, 1) +- end if +-c +- 40 continue +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- cnorm = zzdotc (n, resid, 1, workd, 1) +- rnorm = sqrt(dlapy2(dble(cnorm),aimag(cnorm))) +- else if (bmat .eq. 'I') then +- rnorm = dznrm2(n, resid, 1) +- end if +-c +-c %--------------------------------------% +-c | Check for further orthogonalization. | +-c %--------------------------------------% +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, 1, [rnorm0], ndigit, +- & '_getv0: re-orthonalization ; rnorm0 is') +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_getv0: re-orthonalization ; rnorm is') +- end if +-c +- if (rnorm .gt. 0.717*rnorm0) go to 50 +-c +- iter = iter + 1 +- if (iter .le. 1) then +-c +-c %-----------------------------------% +-c | Perform iterative refinement step | +-c %-----------------------------------% +-c +- rnorm0 = rnorm +- go to 30 +- else +-c +-c %------------------------------------% +-c | Iterative refinement step "failed" | +-c %------------------------------------% +-c +- do 45 jj = 1, n +- resid(jj) = zero +- 45 continue +- rnorm = rzero +- ierr = -1 +- end if +-c +- 50 continue +-c +- if (msglvl .gt. 0) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_getv0: B-norm of initial / restarted starting vector') +- end if +- if (msglvl .gt. 2) then +- call zvout (logfil, n, resid, ndigit, +- & '_getv0: initial / restarted starting vector') +- end if +- ido = 99 +-c +- call arscnd (t1) +- tgetv0 = tgetv0 + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of zgetv0 | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaitr.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaitr.f +deleted file mode 100644 +index 240412ca02..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaitr.f ++++ /dev/null +@@ -1,850 +0,0 @@ +-c\BeginDoc +-c +-c\Name: znaitr +-c +-c\Description: +-c Reverse communication interface for applying NP additional steps to +-c a K step nonsymmetric Arnoldi factorization. +-c +-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T +-c +-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. +-c +-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T +-c +-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. +-c +-c where OP and B are as in znaupd. The B-norm of r_{k+p} is also +-c computed and returned. +-c +-c\Usage: +-c call znaitr +-c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, +-c IPNTR, WORKD, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c This is for the restart phase to force the new +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y, +-c IPNTR(3) is the pointer into WORK for B * X. +-c IDO = 2: compute Y = B * X where +-c IPNTR(1) is the pointer into WORK for X, +-c IPNTR(2) is the pointer into WORK for Y. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c When the routine is used in the "shift-and-invert" mode, the +-c vector B * Q is already available and do not need to be +-c recomputed in forming OP * Q. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. See znaupd. +-c B = 'I' -> standard eigenvalue problem A*x = lambda*x +-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c K Integer. (INPUT) +-c Current size of V and H. +-c +-c NP Integer. (INPUT) +-c Number of additional Arnoldi steps to take. +-c +-c NB Integer. (INPUT) +-c Blocksize to be used in the recurrence. +-c Only work for NB = 1 right now. The goal is to have a +-c program that implement both the block and non-block method. +-c +-c RESID Complex*16 array of length N. (INPUT/OUTPUT) +-c On INPUT: RESID contains the residual vector r_{k}. +-c On OUTPUT: RESID contains the residual vector r_{k+p}. +-c +-c RNORM Double precision scalar. (INPUT/OUTPUT) +-c B-norm of the starting residual on input. +-c B-norm of the updated residual r_{k+p} on output. +-c +-c V Complex*16 N by K+NP array. (INPUT/OUTPUT) +-c On INPUT: V contains the Arnoldi vectors in the first K +-c columns. +-c On OUTPUT: V contains the new NP Arnoldi vectors in the next +-c NP columns. The first K columns are unchanged. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Complex*16 (K+NP) by (K+NP) array. (INPUT/OUTPUT) +-c H is used to store the generated upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORK for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The calling program should not +-c use WORKD as temporary workspace during the iteration !!!!!! +-c On input, WORKD(1:N) = B*RESID and is used to save some +-c computation at the first step. +-c +-c INFO Integer. (OUTPUT) +-c = 0: Normal exit. +-c > 0: Size of the spanning invariant subspace of OP found. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c zgetv0 ARPACK routine to generate the initial vector. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c zmout ARPACK utility routine that prints matrices +-c zvout ARPACK utility routine that prints vectors. +-c zlanhs LAPACK routine that computes various norms of a matrix. +-c zlascl LAPACK routine for careful scaling of a matrix. +-c dlabad LAPACK routine for defining the underflow and overflow +-c limits. +-c dlamch LAPACK routine that determines machine constants. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c zgemv Level 2 BLAS routine for matrix vector multiplication. +-c zaxpy Level 1 BLAS that computes a vector triad. +-c zcopy Level 1 BLAS that copies one vector to another . +-c zdotc Level 1 BLAS that computes the scalar product of two vectors. +-c zscal Level 1 BLAS that scales a vector. +-c zdscal Level 1 BLAS that scales a complex vector by a real number. +-c dznrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 +-c +-c\Remarks +-c The algorithm implemented is: +-c +-c restart = .false. +-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; +-c r_{k} contains the initial residual vector even for k = 0; +-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already +-c computed by the calling program. +-c +-c betaj = rnorm ; p_{k+1} = B*r_{k} ; +-c For j = k+1, ..., k+np Do +-c 1) if ( betaj < tol ) stop or restart depending on j. +-c ( At present tol is zero ) +-c if ( restart ) generate a new starting vector. +-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; +-c p_{j} = p_{j}/betaj +-c 3) r_{j} = OP*v_{j} where OP is defined as in znaupd +-c For shift-invert mode p_{j} = B*v_{j} is already available. +-c wnorm = || OP*v_{j} || +-c 4) Compute the j-th step residual vector. +-c w_{j} = V_{j}^T * B * OP * v_{j} +-c r_{j} = OP*v_{j} - V_{j} * w_{j} +-c H(:,j) = w_{j}; +-c H(j,j-1) = rnorm +-c rnorm = || r_(j) || +-c If (rnorm > 0.717*wnorm) accept step and go back to 1) +-c 5) Re-orthogonalization step: +-c s = V_{j}'*B*r_{j} +-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || +-c alphaj = alphaj + s_{j}; +-c 6) Iterative refinement step: +-c If (rnorm1 > 0.717*rnorm) then +-c rnorm = rnorm1 +-c accept step and go back to 1) +-c Else +-c rnorm = rnorm1 +-c If this is the first time in step 6), go to 5) +-c Else r_{j} lies in the span of V_{j} numerically. +-c Set r_{j} = 0 and rnorm = 0; go to 1) +-c EndIf +-c End Do +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine znaitr +- & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, +- & ipntr, workd, info) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1 +- integer ido, info, k, ldh, ldv, n, nb, np +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(3) +- Complex*16 +- & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- Double precision +- & rone, rzero +- parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), +- & rone = 1.0D+0, rzero = 0.0D+0) +-c +-c %--------------% +-c | Local Arrays | +-c %--------------% +-c +- Double precision +- & rtemp(2) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical first, orth1, orth2, rstart, step3, step4 +- integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, +- & jj +- Double precision +- & ovfl, smlnum, tst1, ulp, unfl, betaj, +- & temp1, rnorm1, wnorm +- Complex*16 +- & cnorm +-c +- save first, orth1, orth2, rstart, step3, step4, +- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, +- & betaj, rnorm1, smlnum, ulp, unfl, wnorm +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zaxpy, zcopy, zscal, zdscal, zgemv, zgetv0, +- & dlabad, zvout, zmout, ivout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Complex*16 +- & zzdotc +- Double precision +- & dlamch, dznrm2, zlanhs, dlapy2 +- external zzdotc, dznrm2, zlanhs, dlamch, dlapy2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic aimag, dble, max, sqrt +-c +-c %-----------------% +-c | Data statements | +-c %-----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------% +-c | Set machine-dependent constants for the | +-c | the splitting and deflation criterion. | +-c | If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine zlahqr | +-c %-----------------------------------------% +-c +- unfl = dlamch( 'safe minimum' ) +- ovfl = dble(one / unfl) +- call dlabad( unfl, ovfl ) +- ulp = dlamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mcaitr +-c +-c %------------------------------% +-c | Initial call to this routine | +-c %------------------------------% +-c +- info = 0 +- step3 = .false. +- step4 = .false. +- rstart = .false. +- orth1 = .false. +- orth2 = .false. +- j = k + 1 +- ipj = 1 +- irj = ipj + n +- ivj = irj + n +- end if +-c +-c %-------------------------------------------------% +-c | When in reverse communication mode one of: | +-c | STEP3, STEP4, ORTH1, ORTH2, RSTART | +-c | will be .true. when .... | +-c | STEP3: return from computing OP*v_{j}. | +-c | STEP4: return from computing B-norm of OP*v_{j} | +-c | ORTH1: return from computing B-norm of r_{j+1} | +-c | ORTH2: return from computing B-norm of | +-c | correction to the residual vector. | +-c | RSTART: return from OP computations needed by | +-c | zgetv0. | +-c %-------------------------------------------------% +-c +- if (step3) go to 50 +- if (step4) go to 60 +- if (orth1) go to 70 +- if (orth2) go to 90 +- if (rstart) go to 30 +-c +-c %-----------------------------% +-c | Else this is the first step | +-c %-----------------------------% +-c +-c %--------------------------------------------------------------% +-c | | +-c | A R N O L D I I T E R A T I O N L O O P | +-c | | +-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | +-c %--------------------------------------------------------------% +- +- 1000 continue +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: generating Arnoldi vector number') +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_naitr: B-norm of the current residual is') +- end if +-c +-c %---------------------------------------------------% +-c | STEP 1: Check if the B norm of j-th residual | +-c | vector is zero. Equivalent to determine whether | +-c | an exact j-step Arnoldi factorization is present. | +-c %---------------------------------------------------% +-c +- betaj = rnorm +- if (rnorm .gt. rzero) go to 40 +-c +-c %---------------------------------------------------% +-c | Invariant subspace found, generate a new starting | +-c | vector which is orthogonal to the current Arnoldi | +-c | basis and continue the iteration. | +-c %---------------------------------------------------% +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: ****** RESTART AT STEP ******') +- end if +-c +-c %---------------------------------------------% +-c | ITRY is the loop variable that controls the | +-c | maximum amount of times that a restart is | +-c | attempted. NRSTRT is used by stat.h | +-c %---------------------------------------------% +-c +- betaj = rzero +- nrstrt = nrstrt + 1 +- itry = 1 +- 20 continue +- rstart = .true. +- ido = 0 +- 30 continue +-c +-c %--------------------------------------% +-c | If in reverse communication mode and | +-c | RSTART = .true. flow returns here. | +-c %--------------------------------------% +-c +- call zgetv0 (ido, bmat, itry, .false., n, j, v, ldv, +- & resid, rnorm, ipntr, workd, ierr) +- if (ido .ne. 99) go to 9000 +- if (ierr .lt. 0) then +- itry = itry + 1 +- if (itry .le. 3) go to 20 +-c +-c %------------------------------------------------% +-c | Give up after several restart attempts. | +-c | Set INFO to the size of the invariant subspace | +-c | which spans OP and exit. | +-c %------------------------------------------------% +-c +- info = j - 1 +- call arscnd (t1) +- tcaitr = tcaitr + (t1 - t0) +- ido = 99 +- go to 9000 +- end if +-c +- 40 continue +-c +-c %---------------------------------------------------------% +-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | +-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | +-c | when reciprocating a small RNORM, test against lower | +-c | machine bound. | +-c %---------------------------------------------------------% +-c +- call zcopy (n, resid, 1, v(1,j), 1) +- if ( rnorm .ge. unfl) then +- temp1 = rone / rnorm +- call zdscal (n, temp1, v(1,j), 1) +- call zdscal (n, temp1, workd(ipj), 1) +- else +-c +-c %-----------------------------------------% +-c | To scale both v_{j} and p_{j} carefully | +-c | use LAPACK routine zlascl | +-c %-----------------------------------------% +-c +- call zlascl ('General', i, i, rnorm, rone, +- & n, 1, v(1,j), n, infol) +- call zlascl ('General', i, i, rnorm, rone, +- & n, 1, workd(ipj), n, infol) +- end if +-c +-c %------------------------------------------------------% +-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | +-c | Note that this is not quite yet r_{j}. See STEP 4 | +-c %------------------------------------------------------% +-c +- step3 = .true. +- nopx = nopx + 1 +- call arscnd (t2) +- call zcopy (n, v(1,j), 1, workd(ivj), 1) +- ipntr(1) = ivj +- ipntr(2) = irj +- ipntr(3) = ipj +- ido = 1 +-c +-c %-----------------------------------% +-c | Exit in order to compute OP*v_{j} | +-c %-----------------------------------% +-c +- go to 9000 +- 50 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | +-c | if step3 = .true. | +-c %----------------------------------% +-c +- call arscnd (t3) +- tmvopx = tmvopx + (t3 - t2) +- +- step3 = .false. +-c +-c %------------------------------------------% +-c | Put another copy of OP*v_{j} into RESID. | +-c %------------------------------------------% +-c +- call zcopy (n, workd(irj), 1, resid, 1) +-c +-c %---------------------------------------% +-c | STEP 4: Finish extending the Arnoldi | +-c | factorization to length j. | +-c %---------------------------------------% +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- step4 = .true. +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-------------------------------------% +-c | Exit in order to compute B*OP*v_{j} | +-c %-------------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call zcopy (n, resid, 1, workd(ipj), 1) +- end if +- 60 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | +-c | if step4 = .true. | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- step4 = .false. +-c +-c %-------------------------------------% +-c | The following is needed for STEP 5. | +-c | Compute the B-norm of OP*v_{j}. | +-c %-------------------------------------% +-c +- if (bmat .eq. 'G') then +- cnorm = zzdotc (n, resid, 1, workd(ipj), 1) +- wnorm = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) +- else if (bmat .eq. 'I') then +- wnorm = dznrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------% +-c | Compute the j-th residual corresponding | +-c | to the j step factorization. | +-c | Use Classical Gram Schmidt and compute: | +-c | w_{j} <- V_{j}^T * B * OP * v_{j} | +-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | +-c %-----------------------------------------% +-c +-c +-c %------------------------------------------% +-c | Compute the j Fourier coefficients w_{j} | +-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | +-c %------------------------------------------% +-c +- call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, +- & zero, h(1,j), 1) +-c +-c %--------------------------------------% +-c | Orthogonalize r_{j} against V_{j}. | +-c | RESID contains OP*v_{j}. See STEP 3. | +-c %--------------------------------------% +-c +- call zgemv ('N', n, j, -one, v, ldv, h(1,j), 1, +- & one, resid, 1) +-c +- if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero, Kind=Kind(0d0)) +-c +- call arscnd (t4) +-c +- orth1 = .true. +-c +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call zcopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*r_{j} | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call zcopy (n, resid, 1, workd(ipj), 1) +- end if +- 70 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH1 = .true. | +-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- orth1 = .false. +-c +-c %------------------------------% +-c | Compute the B-norm of r_{j}. | +-c %------------------------------% +-c +- if (bmat .eq. 'G') then +- cnorm = zzdotc (n, resid, 1, workd(ipj), 1) +- rnorm = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) +- else if (bmat .eq. 'I') then +- rnorm = dznrm2(n, resid, 1) +- end if +-c +-c %-----------------------------------------------------------% +-c | STEP 5: Re-orthogonalization / Iterative refinement phase | +-c | Maximum NITER_ITREF tries. | +-c | | +-c | s = V_{j}^T * B * r_{j} | +-c | r_{j} = r_{j} - V_{j}*s | +-c | alphaj = alphaj + s_{j} | +-c | | +-c | The stopping criteria used for iterative refinement is | +-c | discussed in Parlett's book SEP, page 107 and in Gragg & | +-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | +-c | Determine if we need to correct the residual. The goal is | +-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | +-c | The following test determines whether the sine of the | +-c | angle between OP*x and the computed residual is less | +-c | than or equal to 0.717. | +-c %-----------------------------------------------------------% +-c +- if ( rnorm .gt. 0.717*wnorm ) go to 100 +-c +- iter = 0 +- nrorth = nrorth + 1 +-c +-c %---------------------------------------------------% +-c | Enter the Iterative refinement phase. If further | +-c | refinement is necessary, loop back here. The loop | +-c | variable is ITER. Perform a step of Classical | +-c | Gram-Schmidt using all the Arnoldi vectors V_{j} | +-c %---------------------------------------------------% +-c +- 80 continue +-c +- if (msglvl .gt. 2) then +- rtemp(1) = wnorm +- rtemp(2) = rnorm +- call dvout (logfil, 2, rtemp, ndigit, +- & '_naitr: re-orthogonalization; wnorm and rnorm are') +- call zvout (logfil, j, h(1,j), ndigit, +- & '_naitr: j-th column of H') +- end if +-c +-c %----------------------------------------------------% +-c | Compute V_{j}^T * B * r_{j}. | +-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | +-c %----------------------------------------------------% +-c +- call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, +- & zero, workd(irj), 1) +-c +-c %---------------------------------------------% +-c | Compute the correction to the residual: | +-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | +-c | The correction to H is v(:,1:J)*H(1:J,1:J) | +-c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | +-c %---------------------------------------------% +-c +- call zgemv ('N', n, j, -one, v, ldv, workd(irj), 1, +- & one, resid, 1) +- call zaxpy (j, one, workd(irj), 1, h(1,j), 1) +-c +- orth2 = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call zcopy (n, resid, 1, workd(irj), 1) +- ipntr(1) = irj +- ipntr(2) = ipj +- ido = 2 +-c +-c %-----------------------------------% +-c | Exit in order to compute B*r_{j}. | +-c | r_{j} is the corrected residual. | +-c %-----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call zcopy (n, resid, 1, workd(ipj), 1) +- end if +- 90 continue +-c +-c %---------------------------------------------------% +-c | Back from reverse communication if ORTH2 = .true. | +-c %---------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +-c %-----------------------------------------------------% +-c | Compute the B-norm of the corrected residual r_{j}. | +-c %-----------------------------------------------------% +-c +- if (bmat .eq. 'G') then +- cnorm = zzdotc (n, resid, 1, workd(ipj), 1) +- rnorm1 = sqrt( dlapy2(dble(cnorm),aimag(cnorm)) ) +- else if (bmat .eq. 'I') then +- rnorm1 = dznrm2(n, resid, 1) +- end if +-c +- if (msglvl .gt. 0 .and. iter .gt. 0 ) then +- call ivout (logfil, 1, [j], ndigit, +- & '_naitr: Iterative refinement for Arnoldi residual') +- if (msglvl .gt. 2) then +- rtemp(1) = rnorm +- rtemp(2) = rnorm1 +- call dvout (logfil, 2, rtemp, ndigit, +- & '_naitr: iterative refinement ; rnorm and rnorm1 are') +- end if +- end if +-c +-c %-----------------------------------------% +-c | Determine if we need to perform another | +-c | step of re-orthogonalization. | +-c %-----------------------------------------% +-c +- if ( rnorm1 .gt. 0.717*rnorm ) then +-c +-c %---------------------------------------% +-c | No need for further refinement. | +-c | The cosine of the angle between the | +-c | corrected residual vector and the old | +-c | residual vector is greater than 0.717 | +-c | In other words the corrected residual | +-c | and the old residual vector share an | +-c | angle of less than arcCOS(0.717) | +-c %---------------------------------------% +-c +- rnorm = rnorm1 +-c +- else +-c +-c %-------------------------------------------% +-c | Another step of iterative refinement step | +-c | is required. NITREF is used by stat.h | +-c %-------------------------------------------% +-c +- nitref = nitref + 1 +- rnorm = rnorm1 +- iter = iter + 1 +- if (iter .le. 1) go to 80 +-c +-c %-------------------------------------------------% +-c | Otherwise RESID is numerically in the span of V | +-c %-------------------------------------------------% +-c +- do 95 jj = 1, n +- resid(jj) = zero +- 95 continue +- rnorm = rzero +- end if +-c +-c %----------------------------------------------% +-c | Branch here directly if iterative refinement | +-c | wasn't necessary or after at most NITER_REF | +-c | steps of iterative refinement. | +-c %----------------------------------------------% +-c +- 100 continue +-c +- rstart = .false. +- orth2 = .false. +-c +- call arscnd (t5) +- titref = titref + (t5 - t4) +-c +-c %------------------------------------% +-c | STEP 6: Update j = j+1; Continue | +-c %------------------------------------% +-c +- j = j + 1 +- if (j .gt. k+np) then +- call arscnd (t1) +- tcaitr = tcaitr + (t1 - t0) +- ido = 99 +- do 110 i = max(1,k), k+np-1 +-c +-c %--------------------------------------------% +-c | Check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine zlahqr | +-c %--------------------------------------------% +-c +- tst1 = dlapy2(dble(h(i,i)),aimag(h(i,i))) +- & + dlapy2(dble(h(i+1,i+1)), aimag(h(i+1,i+1))) +- if( tst1.eq.dble(zero) ) +- & tst1 = zlanhs( '1', k+np, h, ldh, workd(n+1) ) +- if( dlapy2(dble(h(i+1,i)),aimag(h(i+1,i))) .le. +- & max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 110 continue +-c +- if (msglvl .gt. 2) then +- call zmout (logfil, k+np, k+np, h, ldh, ndigit, +- & '_naitr: Final upper Hessenberg matrix H of order K+NP') +- end if +-c +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Loop back to extend the factorization by another step. | +-c %--------------------------------------------------------% +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of znaitr | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znapps.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znapps.f +deleted file mode 100644 +index 792fe6168f..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znapps.f ++++ /dev/null +@@ -1,507 +0,0 @@ +-c\BeginDoc +-c +-c\Name: znapps +-c +-c\Description: +-c Given the Arnoldi factorization +-c +-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, +-c +-c apply NP implicit shifts resulting in +-c +-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q +-c +-c where Q is an orthogonal matrix which is the product of rotations +-c and reflections resulting from the NP bulge change sweeps. +-c The updated Arnoldi factorization becomes: +-c +-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. +-c +-c\Usage: +-c call znapps +-c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, +-c WORKL, WORKD ) +-c +-c\Arguments +-c N Integer. (INPUT) +-c Problem size, i.e. size of matrix A. +-c +-c KEV Integer. (INPUT/OUTPUT) +-c KEV+NP is the size of the input matrix H. +-c KEV is the size of the updated matrix HNEW. +-c +-c NP Integer. (INPUT) +-c Number of implicit shifts to be applied. +-c +-c SHIFT Complex*16 array of length NP. (INPUT) +-c The shifts to be applied. +-c +-c V Complex*16 N by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, V contains the current KEV+NP Arnoldi vectors. +-c On OUTPUT, V contains the updated KEV Arnoldi vectors +-c in the first KEV columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Complex*16 (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) +-c On INPUT, H contains the current KEV+NP by KEV+NP upper +-c Hessenberg matrix of the Arnoldi factorization. +-c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg +-c matrix in the KEV leading submatrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RESID Complex*16 array of length N. (INPUT/OUTPUT) +-c On INPUT, RESID contains the the residual vector r_{k+p}. +-c On OUTPUT, RESID is the update residual vector rnew_{k} +-c in the first KEV locations. +-c +-c Q Complex*16 KEV+NP by KEV+NP work array. (WORKSPACE) +-c Work array used to accumulate the rotations and reflections +-c during the bulge chase sweep. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Complex*16 work array of length (KEV+NP). (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c WORKD Complex*16 work array of length 2*N. (WORKSPACE) +-c Distributed array used in the application of the accumulated +-c orthogonal matrix Q. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c zmout ARPACK utility routine that prints matrices +-c zvout ARPACK utility routine that prints vectors. +-c zlacpy LAPACK matrix copy routine. +-c zlanhs LAPACK routine that computes various norms of a matrix. +-c zlartg LAPACK Givens rotation construction routine. +-c zlaset LAPACK matrix initialization routine. +-c dlabad LAPACK routine for defining the underflow and overflow +-c limits. +-c dlamch LAPACK routine that determines machine constants. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c zgemv Level 2 BLAS routine for matrix vector multiplication. +-c zaxpy Level 1 BLAS that computes a vector triad. +-c zcopy Level 1 BLAS that copies one vector to another. +-c zscal Level 1 BLAS that scales a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 +-c +-c\Remarks +-c 1. In this version, each shift is applied to all the sublocks of +-c the Hessenberg matrix H and not just to the submatrix that it +-c comes from. Deflation as in LAPACK routine zlahqr (QR algorithm +-c for upper Hessenberg matrices ) is used. +-c Upon output, the subdiagonals of H are enforced to be non-negative +-c real numbers. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine znapps +- & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, +- & workl, workd ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer kev, ldh, ldq, ldv, n, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex*16 +- & h(ldh,kev+np), resid(n), shift(np), +- & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- Double precision +- & rzero +- parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), +- & rzero = 0.0D+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- integer i, iend, istart, j, jj, kplusp, msglvl +- logical first +- Complex*16 +- & cdum, f, g, h11, h21, r, s, sigma, t +- Double precision +- & c, ovfl, smlnum, ulp, unfl, tst1 +- save first, ovfl, smlnum, ulp, unfl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zaxpy, zcopy, zgemv, zscal, zlacpy, zlartg, +- & zvout, zlaset, dlabad, zmout, arscnd, ivout +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & zlanhs, dlamch, dlapy2 +- external zlanhs, dlamch, dlapy2 +-c +-c %----------------------% +-c | Intrinsics Functions | +-c %----------------------% +-c +- intrinsic abs, aimag, conjg, cmplx, max, min, dble +-c +-c %---------------------% +-c | Statement Functions | +-c %---------------------% +-c +- Double precision +- & zabs1 +- zabs1( cdum ) = abs( dble( cdum ) ) + abs( aimag( cdum ) ) +-c +-c %----------------% +-c | Data statements | +-c %----------------% +-c +- data first / .true. / +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (first) then +-c +-c %-----------------------------------------------% +-c | Set machine-dependent constants for the | +-c | stopping criterion. If norm(H) <= sqrt(OVFL), | +-c | overflow should not occur. | +-c | REFERENCE: LAPACK subroutine zlahqr | +-c %-----------------------------------------------% +-c +- unfl = dlamch( 'safe minimum' ) +- ovfl = dble(one / unfl) +- call dlabad( unfl, ovfl ) +- ulp = dlamch( 'precision' ) +- smlnum = unfl*( n / ulp ) +- first = .false. +- end if +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mcapps +-c +- kplusp = kev + np +-c +-c %--------------------------------------------% +-c | Initialize Q to the identity to accumulate | +-c | the rotations and reflections | +-c %--------------------------------------------% +-c +- call zlaset ('All', kplusp, kplusp, zero, one, q, ldq) +-c +-c %----------------------------------------------% +-c | Quick return if there are no shifts to apply | +-c %----------------------------------------------% +-c +- if (np .eq. 0) go to 9000 +-c +-c %----------------------------------------------% +-c | Chase the bulge with the application of each | +-c | implicit shift. Each shift is applied to the | +-c | whole matrix including each block. | +-c %----------------------------------------------% +-c +- do 110 jj = 1, np +- sigma = shift(jj) +-c +- if (msglvl .gt. 2 ) then +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: shift number.') +- call zvout (logfil, 1, [sigma], ndigit, +- & '_napps: Value of the shift ') +- end if +-c +- istart = 1 +- 20 continue +-c +- do 30 i = istart, kplusp-1 +-c +-c %----------------------------------------% +-c | Check for splitting and deflation. Use | +-c | a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine zlahqr | +-c %----------------------------------------% +-c +- tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) +- if( tst1.eq.rzero ) +- & tst1 = zlanhs( '1', kplusp-jj+1, h, ldh, workl ) +- if ( abs(dble(h(i+1,i))) +- & .le. max(ulp*tst1, smlnum) ) then +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [i], ndigit, +- & '_napps: matrix splitting at row/column no.') +- call ivout (logfil, 1, [jj], ndigit, +- & '_napps: matrix splitting with shift number.') +- call zvout (logfil, 1, h(i+1,i), ndigit, +- & '_napps: off diagonal element.') +- end if +- iend = i +- h(i+1,i) = zero +- go to 40 +- end if +- 30 continue +- iend = kplusp +- 40 continue +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [istart], ndigit, +- & '_napps: Start of current block ') +- call ivout (logfil, 1, [iend], ndigit, +- & '_napps: End of current block ') +- end if +-c +-c %------------------------------------------------% +-c | No reason to apply a shift to block of order 1 | +-c | or if the current block starts after the point | +-c | of compression since we'll discard this stuff | +-c %------------------------------------------------% +-c +- if ( istart .eq. iend .or. istart .gt. kev) go to 100 +-c +- h11 = h(istart,istart) +- h21 = h(istart+1,istart) +- f = h11 - sigma +- g = h21 +-c +- do 80 i = istart, iend-1 +-c +-c %------------------------------------------------------% +-c | Construct the plane rotation G to zero out the bulge | +-c %------------------------------------------------------% +-c +- call zlartg (f, g, c, s, r) +- if (i .gt. istart) then +- h(i,i-1) = r +- h(i+1,i-1) = zero +- end if +-c +-c %---------------------------------------------% +-c | Apply rotation to the left of H; H <- G'*H | +-c %---------------------------------------------% +-c +- do 50 j = i, kplusp +- t = c*h(i,j) + s*h(i+1,j) +- h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) +- h(i,j) = t +- 50 continue +-c +-c %---------------------------------------------% +-c | Apply rotation to the right of H; H <- H*G | +-c %---------------------------------------------% +-c +- do 60 j = 1, min(i+2,iend) +- t = c*h(j,i) + conjg(s)*h(j,i+1) +- h(j,i+1) = -s*h(j,i) + c*h(j,i+1) +- h(j,i) = t +- 60 continue +-c +-c %-----------------------------------------------------% +-c | Accumulate the rotation in the matrix Q; Q <- Q*G' | +-c %-----------------------------------------------------% +-c +- do 70 j = 1, min(i+jj, kplusp) +- t = c*q(j,i) + conjg(s)*q(j,i+1) +- q(j,i+1) = - s*q(j,i) + c*q(j,i+1) +- q(j,i) = t +- 70 continue +-c +-c %---------------------------% +-c | Prepare for next rotation | +-c %---------------------------% +-c +- if (i .lt. iend-1) then +- f = h(i+1,i) +- g = h(i+2,i) +- end if +- 80 continue +-c +-c %-------------------------------% +-c | Finished applying the shift. | +-c %-------------------------------% +-c +- 100 continue +-c +-c %---------------------------------------------------------% +-c | Apply the same shift to the next block if there is any. | +-c %---------------------------------------------------------% +-c +- istart = iend + 1 +- if (iend .lt. kplusp) go to 20 +-c +-c %---------------------------------------------% +-c | Loop back to the top to get the next shift. | +-c %---------------------------------------------% +-c +- 110 continue +-c +-c %---------------------------------------------------% +-c | Perform a similarity transformation that makes | +-c | sure that the compressed H will have non-negative | +-c | real subdiagonal elements. | +-c %---------------------------------------------------% +-c +- do 120 j=1,kev +- if ( dble( h(j+1,j) ) .lt. rzero .or. +- & aimag( h(j+1,j) ) .ne. rzero ) then +- t = h(j+1,j) / dlapy2(dble(h(j+1,j)),aimag(h(j+1,j))) +- call zscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) +- call zscal( min(j+2, kplusp), t, h(1,j+1), 1 ) +- call zscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) +- h(j+1,j) = cmplx( dble( h(j+1,j) ), rzero, Kind=Kind(0d0) ) +- end if +- 120 continue +-c +- do 130 i = 1, kev +-c +-c %--------------------------------------------% +-c | Final check for splitting and deflation. | +-c | Use a standard test as in the QR algorithm | +-c | REFERENCE: LAPACK subroutine zlahqr. | +-c | Note: Since the subdiagonals of the | +-c | compressed H are nonnegative real numbers, | +-c | we take advantage of this. | +-c %--------------------------------------------% +-c +- tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) +- if( tst1 .eq. rzero ) +- & tst1 = zlanhs( '1', kev, h, ldh, workl ) +- if( dble( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) +- & h(i+1,i) = zero +- 130 continue +-c +-c %-------------------------------------------------% +-c | Compute the (kev+1)-st column of (V*Q) and | +-c | temporarily store the result in WORKD(N+1:2*N). | +-c | This is needed in the residual update since we | +-c | cannot GUARANTEE that the corresponding entry | +-c | of H would be zero as in exact arithmetic. | +-c %-------------------------------------------------% +-c +- if ( dble( h(kev+1,kev) ) .gt. rzero ) +- & call zgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, +- & workd(n+1), 1) +-c +-c %----------------------------------------------------------% +-c | Compute column 1 to kev of (V*Q) in backward order | +-c | taking advantage of the upper Hessenberg structure of Q. | +-c %----------------------------------------------------------% +-c +- do 140 i = 1, kev +- call zgemv ('N', n, kplusp-i+1, one, v, ldv, +- & q(1,kev-i+1), 1, zero, workd, 1) +- call zcopy (n, workd, 1, v(1,kplusp-i+1), 1) +- 140 continue +-c +-c %-------------------------------------------------% +-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | +-c %-------------------------------------------------% +-c +- call zlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) +-c +-c %--------------------------------------------------------------% +-c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | +-c %--------------------------------------------------------------% +-c +- if ( dble( h(kev+1,kev) ) .gt. rzero ) +- & call zcopy (n, workd(n+1), 1, v(1,kev+1), 1) +-c +-c %-------------------------------------% +-c | Update the residual vector: | +-c | r <- sigmak*r + betak*v(:,kev+1) | +-c | where | +-c | sigmak = (e_{kev+p}'*Q)*e_{kev} | +-c | betak = e_{kev+1}'*H*e_{kev} | +-c %-------------------------------------% +-c +- call zscal (n, q(kplusp,kev), resid, 1) +- if ( dble( h(kev+1,kev) ) .gt. rzero ) +- & call zaxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) +-c +- if (msglvl .gt. 1) then +- call zvout (logfil, 1, q(kplusp,kev), ndigit, +- & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') +- call zvout (logfil, 1, h(kev+1,kev), ndigit, +- & '_napps: betak = e_{kev+1}^T*H*e_{kev}') +- call ivout (logfil, 1, [kev], ndigit, +- & '_napps: Order of the final Hessenberg matrix ') +- if (msglvl .gt. 2) then +- call zmout (logfil, kev, kev, h, ldh, ndigit, +- & '_napps: updated Hessenberg matrix H for next iteration') +- end if +-c +- end if +-c +- 9000 continue +- call arscnd (t1) +- tcapps = tcapps + (t1 - t0) +-c +- return +-c +-c %---------------% +-c | End of znapps | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaup2.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaup2.f +deleted file mode 100644 +index 0ab01dd0eb..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaup2.f ++++ /dev/null +@@ -1,801 +0,0 @@ +-c\BeginDoc +-c +-c\Name: znaup2 +-c +-c\Description: +-c Intermediate level interface called by znaupd . +-c +-c\Usage: +-c call znaup2 +-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, +-c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, +-c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) +-c +-c\Arguments +-c +-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in znaupd . +-c MODE, ISHIFT, MXITER: see the definition of IPARAM in znaupd . +-c +-c NP Integer. (INPUT/OUTPUT) +-c Contains the number of implicit shifts to apply during +-c each Arnoldi iteration. +-c If ISHIFT=1, NP is adjusted dynamically at each iteration +-c to accelerate convergence and prevent stagnation. +-c This is also roughly equal to the number of matrix-vector +-c products (involving the operator OP) per Arnoldi iteration. +-c The logic for adjusting is contained within the current +-c subroutine. +-c If ISHIFT=0, NP is the number of shifts the user needs +-c to provide via reverse communication. 0 < NP < NCV-NEV. +-c NP may be less than NCV-NEV since a leading block of the current +-c upper Hessenberg matrix has split off and contains "unwanted" +-c Ritz values. +-c Upon termination of the IRA iteration, NP contains the number +-c of "converged" wanted Ritz values. +-c +-c IUPD Integer. (INPUT) +-c IUPD .EQ. 0: use explicit restart instead implicit update. +-c IUPD .NE. 0: use implicit update. +-c +-c V Complex*16 N by (NEV+NP) array. (INPUT/OUTPUT) +-c The Arnoldi basis vectors are returned in the first NEV +-c columns of V. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling +-c program. +-c +-c H Complex*16 (NEV+NP) by (NEV+NP) array. (OUTPUT) +-c H is used to store the generated upper Hessenberg matrix +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZ Complex*16 array of length NEV+NP. (OUTPUT) +-c RITZ(1:NEV) contains the computed Ritz values of OP. +-c +-c BOUNDS Complex*16 array of length NEV+NP. (OUTPUT) +-c BOUNDS(1:NEV) contain the error bounds corresponding to +-c the computed Ritz values. +-c +-c Q Complex*16 (NEV+NP) by (NEV+NP) array. (WORKSPACE) +-c Private (replicated) work array used to accumulate the +-c rotation in the shift application step. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Complex*16 work array of length at least +-c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. It is used in shifts calculation, shifts +-c application and convergence checking. +-c +-c +-c IPNTR Integer array of length 3. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD for +-c vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X. +-c IPNTR(2): pointer to the current result vector Y. +-c IPNTR(3): pointer to the vector B * X when used in the +-c shift-and-invert mode. X is the current operand. +-c ------------------------------------------------------------- +-c +-c WORKD Complex*16 work array of length 3*N. (WORKSPACE) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note in ZNAUPD . +-c +-c RWORK Double precision work array of length NEV+NP ( WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal return. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. +-c NP returns the number of converged Ritz values. +-c = 2: No shifts could be applied. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c This should never happen. +-c = -9: Starting vector is zero. +-c = -9999: Could not build an Arnoldi factorization. +-c Size that was built in returned in NP. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c +-c\Routines called: +-c zgetv0 ARPACK initial vector generation routine. +-c znaitr ARPACK Arnoldi factorization routine. +-c znapps ARPACK application of implicit shifts routine. +-c zneigh ARPACK compute Ritz values and error bounds routine. +-c zngets ARPACK reorder Ritz values and error bounds routine. +-c zsortc ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c zmout ARPACK utility routine that prints matrices +-c zvout ARPACK utility routine that prints vectors. +-c dvout ARPACK utility routine that prints vectors. +-c dlamch LAPACK routine that determines machine constants. +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c zcopy Level 1 BLAS that copies one vector to another . +-c zdotc Level 1 BLAS that computes the scalar product of two vectors. +-c zswap Level 1 BLAS that swaps two vectors. +-c dznrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice Universitya +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 +-c +-c\Remarks +-c 1. None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine znaup2 +- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, +- & q, ldq, workl, ipntr, workd, rwork, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, +- & n, nev, np +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer ipntr(13) +- Complex*16 +- & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), +- & resid(n), ritz(nev+np), v(ldv,nev+np), +- & workd(3*n), workl( (nev+np)*(nev+np+3) ) +- Double precision +- & rwork(nev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- Double precision +- & rzero +- parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) , +- & rzero = 0.0D+0 ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- logical cnorm , getv0, initv , update, ushift +- integer ierr , iter , kplusp, msglvl, nconv, +- & nevbef, nev0 , np0 , nptemp, i , +- & j +- Complex*16 +- & cmpnorm +- Double precision +- & rnorm , eps23, rtemp +- character wprime*2 +-c +- save cnorm, getv0, initv , update, ushift, +- & rnorm, iter , kplusp, msglvl, nconv , +- & nevbef, nev0 , np0 , eps23 +-c +-c +-c %-----------------------% +-c | Local array arguments | +-c %-----------------------% +-c +- integer kp(3) +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zcopy , zgetv0 , znaitr , zneigh , zngets , znapps , +- & zsortc , zswap , zmout , zvout , ivout, arscnd +-c +-c %--------------------% +-c | External functions | +-c %--------------------% +-c +- Complex*16 +- & zzdotc +- Double precision +- & dznrm2 , dlamch , dlapy2 +- external zzdotc , dznrm2 , dlamch , dlapy2 +-c +-c %---------------------% +-c | Intrinsic Functions | +-c %---------------------% +-c +- intrinsic aimag , dble , min, max +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +- call arscnd (t0) +-c +- msglvl = mcaup2 +-c +- nev0 = nev +- np0 = np +-c +-c %-------------------------------------% +-c | kplusp is the bound on the largest | +-c | Lanczos factorization built. | +-c | nconv is the current number of | +-c | "converged" eigenvalues. | +-c | iter is the counter on the current | +-c | iteration step. | +-c %-------------------------------------% +-c +- kplusp = nev + np +- nconv = 0 +- iter = 0 +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = dlamch ('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0 ) +-c +-c %---------------------------------------% +-c | Set flags for computing the first NEV | +-c | steps of the Arnoldi factorization. | +-c %---------------------------------------% +-c +- getv0 = .true. +- update = .false. +- ushift = .false. +- cnorm = .false. +-c +- if (info .ne. 0) then +-c +-c %--------------------------------------------% +-c | User provides the initial residual vector. | +-c %--------------------------------------------% +-c +- initv = .true. +- info = 0 +- else +- initv = .false. +- end if +- end if +-c +-c %---------------------------------------------% +-c | Get a possibly random starting vector and | +-c | force it into the range of the operator OP. | +-c %---------------------------------------------% +-c +- 10 continue +-c +- if (getv0) then +- call zgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, +- & ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (rnorm .eq. rzero) then +-c +-c %-----------------------------------------% +-c | The initial vector is zero. Error exit. | +-c %-----------------------------------------% +-c +- info = -9 +- go to 1100 +- end if +- getv0 = .false. +- ido = 0 +- end if +-c +-c %-----------------------------------% +-c | Back from reverse communication : | +-c | continue with update step | +-c %-----------------------------------% +-c +- if (update) go to 20 +-c +-c %-------------------------------------------% +-c | Back from computing user specified shifts | +-c %-------------------------------------------% +-c +- if (ushift) go to 50 +-c +-c %-------------------------------------% +-c | Back from computing residual norm | +-c | at the end of the current iteration | +-c %-------------------------------------% +-c +- if (cnorm) go to 100 +-c +-c %----------------------------------------------------------% +-c | Compute the first NEV steps of the Arnoldi factorization | +-c %----------------------------------------------------------% +-c +- call znaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, +- & h, ldh, ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +-c +-c %--------------------------------------------------------------% +-c | | +-c | M A I N ARNOLDI I T E R A T I O N L O O P | +-c | Each iteration implicitly restarts the Arnoldi | +-c | factorization in place. | +-c | | +-c %--------------------------------------------------------------% +-c +- 1000 continue +-c +- iter = iter + 1 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [iter], ndigit, +- & '_naup2: **** Start of major iteration number ****') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c | Adjust NP since NEV might have been updated by last call | +-c | to the shift application routine znapps . | +-c %-----------------------------------------------------------% +-c +- np = kplusp - nev +-c +- if (msglvl .gt. 1) then +- call ivout (logfil, 1, [nev], ndigit, +- & '_naup2: The length of the current Arnoldi factorization') +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: Extend the Arnoldi factorization by') +- end if +-c +-c %-----------------------------------------------------------% +-c | Compute NP additional steps of the Arnoldi factorization. | +-c %-----------------------------------------------------------% +-c +- ido = 0 +- 20 continue +- update = .true. +-c +- call znaitr (ido, bmat, n, nev, np, mode, resid, rnorm, +- & v , ldv , h, ldh, ipntr, workd, info) +-c +- if (ido .ne. 99) go to 9000 +-c +- if (info .gt. 0) then +- np = info +- mxiter = iter +- info = -9999 +- go to 1200 +- end if +- update = .false. +-c +- if (msglvl .gt. 1) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_naup2: Corresponding B-norm of the residual') +- end if +-c +-c %--------------------------------------------------------% +-c | Compute the eigenvalues and corresponding error bounds | +-c | of the current upper Hessenberg matrix. | +-c %--------------------------------------------------------% +-c +- call zneigh (rnorm, kplusp, h, ldh, ritz, bounds, +- & q, ldq, workl, rwork, ierr) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 1200 +- end if +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The wanted part of the spectrum and corresponding | +-c | error bounds are in the last NEV loc. of RITZ, | +-c | and BOUNDS respectively. | +-c %---------------------------------------------------% +-c +- nev = nev0 +- np = np0 +-c +-c %--------------------------------------------------% +-c | Make a copy of Ritz values and the corresponding | +-c | Ritz estimates obtained from zneigh . | +-c %--------------------------------------------------% +-c +- call zcopy (kplusp,ritz,1,workl(kplusp**2+1),1) +- call zcopy (kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) +-c +-c %---------------------------------------------------% +-c | Select the wanted Ritz values and their bounds | +-c | to be used in the convergence test. | +-c | The wanted part of the spectrum and corresponding | +-c | bounds are in the last NEV loc. of RITZ | +-c | BOUNDS respectively. | +-c %---------------------------------------------------% +-c +- call zngets (ishift, which, nev, np, ritz, bounds) +-c +-c %------------------------------------------------------------% +-c | Convergence test: currently we use the following criteria. | +-c | The relative accuracy of a Ritz value is considered | +-c | acceptable if: | +-c | | +-c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | +-c | | +-c %------------------------------------------------------------% +-c +- nconv = 0 +-c +- do 25 i = 1, nev +- rtemp = max( eps23, dlapy2 ( dble (ritz(np+i)), +- & aimag (ritz(np+i)) ) ) +- if ( dlapy2 (dble (bounds(np+i)),aimag (bounds(np+i))) +- & .le. tol*rtemp ) then +- nconv = nconv + 1 +- end if +- 25 continue +-c +- if (msglvl .gt. 2) then +- kp(1) = nev +- kp(2) = np +- kp(3) = nconv +- call ivout (logfil, 3, kp, ndigit, +- & '_naup2: NEV, NP, NCONV are') +- call zvout (logfil, kplusp, ritz, ndigit, +- & '_naup2: The eigenvalues of H') +- call zvout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Ritz estimates of the current NCV Ritz values') +- end if +-c +-c %---------------------------------------------------------% +-c | Count the number of unwanted Ritz values that have zero | +-c | Ritz estimates. If any Ritz estimates are equal to zero | +-c | then a leading block of H of order equal to at least | +-c | the number of Ritz values with zero Ritz estimates has | +-c | split off. None of these Ritz values may be removed by | +-c | shifting. Decrease NP the number of shifts to apply. If | +-c | no shifts may be applied, then prepare to exit | +-c %---------------------------------------------------------% +-c +- nptemp = np +- do 30 j=1, nptemp +- if (bounds(j) .eq. zero) then +- np = np - 1 +- nev = nev + 1 +- end if +- 30 continue +-c +- if ( (nconv .ge. nev0) .or. +- & (iter .gt. mxiter) .or. +- & (np .eq. 0) ) then +-c +- if (msglvl .gt. 4) then +- call zvout (logfil, kplusp, workl(kplusp**2+1), ndigit, +- & '_naup2: Eigenvalues computed by _neigh:') +- call zvout (logfil, kplusp, workl(kplusp**2+kplusp+1), +- & ndigit, +- & '_naup2: Ritz estimates computed by _neigh:') +- end if +-c +-c %------------------------------------------------% +-c | Prepare to exit. Put the converged Ritz values | +-c | and corresponding bounds in RITZ(1:NCONV) and | +-c | BOUNDS(1:NCONV) respectively. Then sort. Be | +-c | careful when NCONV > NP | +-c %------------------------------------------------% +-c +-c %------------------------------------------% +-c | Use h( 3,1 ) as storage to communicate | +-c | rnorm to zneupd if needed | +-c %------------------------------------------% +- +- h(3,1) = cmplx (rnorm,rzero,Kind=Kind(0d0)) +-c +-c %----------------------------------------------% +-c | Sort Ritz values so that converged Ritz | +-c | values appear within the first NEV locations | +-c | of ritz and bounds, and the most desired one | +-c | appears at the front. | +-c %----------------------------------------------% +-c +- if (which .eq. 'LM') wprime = 'SM' +- if (which .eq. 'SM') wprime = 'LM' +- if (which .eq. 'LR') wprime = 'SR' +- if (which .eq. 'SR') wprime = 'LR' +- if (which .eq. 'LI') wprime = 'SI' +- if (which .eq. 'SI') wprime = 'LI' +-c +- call zsortc (wprime, .true., kplusp, ritz, bounds) +-c +-c %--------------------------------------------------% +-c | Scale the Ritz estimate of each Ritz value | +-c | by 1 / max(eps23, magnitude of the Ritz value). | +-c %--------------------------------------------------% +-c +- do 35 j = 1, nev0 +- rtemp = max( eps23, dlapy2 ( dble (ritz(j)), +- & aimag (ritz(j)) ) ) +- bounds(j) = bounds(j)/rtemp +- 35 continue +-c +-c %---------------------------------------------------% +-c | Sort the Ritz values according to the scaled Ritz | +-c | estimates. This will push all the converged ones | +-c | towards the front of ritz, bounds (in the case | +-c | when NCONV < NEV.) | +-c %---------------------------------------------------% +-c +- wprime = 'LM' +- call zsortc (wprime, .true., nev0, bounds, ritz) +-c +-c %----------------------------------------------% +-c | Scale the Ritz estimate back to its original | +-c | value. | +-c %----------------------------------------------% +-c +- do 40 j = 1, nev0 +- rtemp = max( eps23, dlapy2 ( dble (ritz(j)), +- & aimag (ritz(j)) ) ) +- bounds(j) = bounds(j)*rtemp +- 40 continue +-c +-c %-----------------------------------------------% +-c | Sort the converged Ritz values again so that | +-c | the "threshold" value appears at the front of | +-c | ritz and bound. | +-c %-----------------------------------------------% +-c +- call zsortc (which, .true., nconv, ritz, bounds) +-c +- if (msglvl .gt. 1) then +- call zvout (logfil, kplusp, ritz, ndigit, +- & '_naup2: Sorted eigenvalues') +- call zvout (logfil, kplusp, bounds, ndigit, +- & '_naup2: Sorted ritz estimates.') +- end if +-c +-c %------------------------------------% +-c | Max iterations have been exceeded. | +-c %------------------------------------% +-c +- if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 +-c +-c %---------------------% +-c | No shifts to apply. | +-c %---------------------% +-c +- if (np .eq. 0 .and. nconv .lt. nev0) info = 2 +-c +- np = nconv +- go to 1100 +-c +- else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then +-c +-c %-------------------------------------------------% +-c | Do not have all the requested eigenvalues yet. | +-c | To prevent possible stagnation, adjust the size | +-c | of NEV. | +-c %-------------------------------------------------% +-c +- nevbef = nev +- nev = nev + min(nconv, np/2) +- if (nev .eq. 1 .and. kplusp .ge. 6) then +- nev = kplusp / 2 +- else if (nev .eq. 1 .and. kplusp .gt. 3) then +- nev = 2 +- end if +- np = kplusp - nev +-c +-c %---------------------------------------% +-c | If the size of NEV was just increased | +-c | resort the eigenvalues. | +-c %---------------------------------------% +-c +- if (nevbef .lt. nev) +- & call zngets (ishift, which, nev, np, ritz, bounds) +-c +- end if +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [nconv], ndigit, +- & '_naup2: no. of "converged" Ritz values at this iter.') +- if (msglvl .gt. 1) then +- kp(1) = nev +- kp(2) = np +- call ivout (logfil, 2, kp, ndigit, +- & '_naup2: NEV and NP are') +- call zvout (logfil, nev, ritz(np+1), ndigit, +- & '_naup2: "wanted" Ritz values ') +- call zvout (logfil, nev, bounds(np+1), ndigit, +- & '_naup2: Ritz estimates of the "wanted" values ') +- end if +- end if +-c +- if (ishift .eq. 0) then +-c +-c %-------------------------------------------------------% +-c | User specified shifts: pop back out to get the shifts | +-c | and return them in the first 2*NP locations of WORKL. | +-c %-------------------------------------------------------% +-c +- ushift = .true. +- ido = 3 +- go to 9000 +- end if +- 50 continue +- ushift = .false. +-c +- if ( ishift .ne. 1 ) then +-c +-c %----------------------------------% +-c | Move the NP shifts from WORKL to | +-c | RITZ, to free up WORKL | +-c | for non-exact shift case. | +-c %----------------------------------% +-c +- call zcopy (np, workl, 1, ritz, 1) +- end if +-c +- if (msglvl .gt. 2) then +- call ivout (logfil, 1, [np], ndigit, +- & '_naup2: The number of shifts to apply ') +- call zvout (logfil, np, ritz, ndigit, +- & '_naup2: values of the shifts') +- if ( ishift .eq. 1 ) +- & call zvout (logfil, np, bounds, ndigit, +- & '_naup2: Ritz estimates of the shifts') +- end if +-c +-c %---------------------------------------------------------% +-c | Apply the NP implicit shifts by QR bulge chasing. | +-c | Each shift is applied to the whole upper Hessenberg | +-c | matrix H. | +-c | The first 2*N locations of WORKD are used as workspace. | +-c %---------------------------------------------------------% +-c +- call znapps (n, nev, np, ritz, v, ldv, +- & h, ldh, resid, q, ldq, workl, workd) +-c +-c %---------------------------------------------% +-c | Compute the B-norm of the updated residual. | +-c | Keep B*RESID in WORKD(1:N) to be used in | +-c | the first step of the next call to znaitr . | +-c %---------------------------------------------% +-c +- cnorm = .true. +- call arscnd (t2) +- if (bmat .eq. 'G') then +- nbx = nbx + 1 +- call zcopy (n, resid, 1, workd(n+1), 1) +- ipntr(1) = n + 1 +- ipntr(2) = 1 +- ido = 2 +-c +-c %----------------------------------% +-c | Exit in order to compute B*RESID | +-c %----------------------------------% +-c +- go to 9000 +- else if (bmat .eq. 'I') then +- call zcopy (n, resid, 1, workd, 1) +- end if +-c +- 100 continue +-c +-c %----------------------------------% +-c | Back from reverse communication; | +-c | WORKD(1:N) := B*RESID | +-c %----------------------------------% +-c +- if (bmat .eq. 'G') then +- call arscnd (t3) +- tmvbx = tmvbx + (t3 - t2) +- end if +-c +- if (bmat .eq. 'G') then +- cmpnorm = zzdotc (n, resid, 1, workd, 1) +- rnorm = sqrt(dlapy2 (dble (cmpnorm),aimag (cmpnorm))) +- else if (bmat .eq. 'I') then +- rnorm = dznrm2 (n, resid, 1) +- end if +- cnorm = .false. +-c +- if (msglvl .gt. 2) then +- call dvout (logfil, 1, [rnorm], ndigit, +- & '_naup2: B-norm of residual for compressed factorization') +- call zmout (logfil, nev, nev, h, ldh, ndigit, +- & '_naup2: Compressed upper Hessenberg matrix H') +- end if +-c +- go to 1000 +-c +-c %---------------------------------------------------------------% +-c | | +-c | E N D O F M A I N I T E R A T I O N L O O P | +-c | | +-c %---------------------------------------------------------------% +-c +- 1100 continue +-c +- mxiter = iter +- nev = nconv +-c +- 1200 continue +- ido = 99 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- call arscnd (t1) +- tcaup2 = t1 - t0 +-c +- 9000 continue +-c +-c %---------------% +-c | End of znaup2 | +-c %---------------% +-c +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaupd.f +deleted file mode 100644 +index c7d58aaab9..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/znaupd.f ++++ /dev/null +@@ -1,664 +0,0 @@ +-c\BeginDoc +-c +-c\Name: znaupd +-c +-c\Description: +-c Reverse communication interface for the Implicitly Restarted Arnoldi +-c iteration. This is intended to be used to find a few eigenpairs of a +-c complex linear operator OP with respect to a semi-inner product defined +-c by a hermitian positive semi-definite real matrix B. B may be the identity +-c matrix. NOTE: if both OP and B are real, then dsaupd or dnaupd should +-c be used. +-c +-c +-c The computed approximate eigenvalues are called Ritz values and +-c the corresponding approximate eigenvectors are called Ritz vectors. +-c +-c znaupd is usually called iteratively to solve one of the +-c following problems: +-c +-c Mode 1: A*x = lambda*x. +-c ===> OP = A and B = I. +-c +-c Mode 2: A*x = lambda*M*x, M hermitian positive definite +-c ===> OP = inv[M]*A and B = M. +-c ===> (If M can be factored see remark 3 below) +-c +-c Mode 3: A*x = lambda*M*x, M hermitian semi-definite +-c ===> OP = inv[A - sigma*M]*M and B = M. +-c ===> shift-and-invert mode +-c If OP*x = amu*x, then lambda = sigma + 1/amu. +-c +-c +-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v +-c should be accomplished either by a direct method +-c using a sparse matrix factorization and solving +-c +-c [A - sigma*M]*w = v or M*w = v, +-c +-c or through an iterative method for solving these +-c systems. If an iterative method is used, the +-c convergence test must be more stringent than +-c the accuracy requirements for the eigenvalue +-c approximations. +-c +-c\Usage: +-c call znaupd +-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, +-c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) +-c +-c\Arguments +-c IDO Integer. (INPUT/OUTPUT) +-c Reverse communication flag. IDO must be zero on the first +-c call to znaupd . IDO will be set internally to +-c indicate the type of operation to be performed. Control is +-c then given back to the calling routine which has the +-c responsibility to carry out the requested operation and call +-c znaupd with the result. The operand is given in +-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). +-c ------------------------------------------------------------- +-c IDO = 0: first call to the reverse communication interface +-c IDO = -1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c This is for the initialization phase to force the +-c starting vector into the range of OP. +-c IDO = 1: compute Y = OP * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c In mode 3, the vector B * X is already +-c available in WORKD(ipntr(3)). It does not +-c need to be recomputed in forming OP * X. +-c IDO = 2: compute Y = M * X where +-c IPNTR(1) is the pointer into WORKD for X, +-c IPNTR(2) is the pointer into WORKD for Y. +-c IDO = 3: compute and return the shifts in the first +-c NP locations of WORKL. +-c IDO = 99: done +-c ------------------------------------------------------------- +-c After the initialization phase, when the routine is used in +-c the "shift-and-invert" mode, the vector M * X is already +-c available and does not need to be recomputed in forming OP*X. +-c +-c BMAT Character*1. (INPUT) +-c BMAT specifies the type of the matrix B that defines the +-c semi-inner product for the operator OP. +-c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x +-c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x +-c +-c N Integer. (INPUT) +-c Dimension of the eigenproblem. +-c +-c WHICH Character*2. (INPUT) +-c 'LM' -> want the NEV eigenvalues of largest magnitude. +-c 'SM' -> want the NEV eigenvalues of smallest magnitude. +-c 'LR' -> want the NEV eigenvalues of largest real part. +-c 'SR' -> want the NEV eigenvalues of smallest real part. +-c 'LI' -> want the NEV eigenvalues of largest imaginary part. +-c 'SI' -> want the NEV eigenvalues of smallest imaginary part. +-c +-c NEV Integer. (INPUT) +-c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. +-c +-c TOL Double precision scalar. (INPUT) +-c Stopping criteria: the relative accuracy of the Ritz value +-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) +-c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. +-c DEFAULT = dlamch ('EPS') (machine precision as computed +-c by the LAPACK auxiliary subroutine dlamch ). +-c +-c RESID Complex*16 array of length N. (INPUT/OUTPUT) +-c On INPUT: +-c If INFO .EQ. 0, a random initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c On OUTPUT: +-c RESID contains the final residual vector. +-c +-c NCV Integer. (INPUT) +-c Number of columns of the matrix V. NCV must satisfy the two +-c inequalities 1 <= NCV-NEV and NCV <= N. +-c This will indicate how many Arnoldi vectors are generated +-c at each iteration. After the startup phase in which NEV +-c Arnoldi vectors are generated, the algorithm generates +-c approximately NCV-NEV Arnoldi vectors at each subsequent update +-c iteration. Most of the cost in generating each Arnoldi vector is +-c in the matrix-vector operation OP*x. (See remark 4 below.) +-c +-c V Complex*16 array N by NCV. (OUTPUT) +-c Contains the final set of Arnoldi basis vectors. +-c +-c LDV Integer. (INPUT) +-c Leading dimension of V exactly as declared in the calling program. +-c +-c IPARAM Integer array of length 11. (INPUT/OUTPUT) +-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. +-c The shifts selected at each iteration are used to filter out +-c the components of the unwanted eigenvector. +-c ------------------------------------------------------------- +-c ISHIFT = 0: the shifts are to be provided by the user via +-c reverse communication. The NCV eigenvalues of +-c the Hessenberg matrix H are returned in the part +-c of WORKL array corresponding to RITZ. +-c ISHIFT = 1: exact shifts with respect to the current +-c Hessenberg matrix H. This is equivalent to +-c restarting the iteration from the beginning +-c after updating the starting vector with a linear +-c combination of Ritz vectors associated with the +-c "wanted" eigenvalues. +-c ISHIFT = 2: other choice of internal shift to be defined. +-c ------------------------------------------------------------- +-c +-c IPARAM(2) = No longer referenced +-c +-c IPARAM(3) = MXITER +-c On INPUT: maximum number of Arnoldi update iterations allowed. +-c On OUTPUT: actual number of Arnoldi update iterations taken. +-c +-c IPARAM(4) = NB: blocksize to be used in the recurrence. +-c The code currently works only for NB = 1. +-c +-c IPARAM(5) = NCONV: number of "converged" Ritz values. +-c This represents the number of Ritz values that satisfy +-c the convergence criterion. +-c +-c IPARAM(6) = IUPD +-c No longer referenced. Implicit restarting is ALWAYS used. +-c +-c IPARAM(7) = MODE +-c On INPUT determines what type of eigenproblem is being solved. +-c Must be 1,2,3; See under \Description of znaupd for the +-c four modes available. +-c +-c IPARAM(8) = NP +-c When ido = 3 and the user provides shifts through reverse +-c communication (IPARAM(1)=0), _naupd returns NP, the number +-c of shifts the user is to provide. 0 < NP < NCV-NEV. +-c +-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, +-c OUTPUT: NUMOP = total number of OP*x operations, +-c NUMOPB = total number of B*x operations if BMAT='G', +-c NUMREO = total number of steps of re-orthogonalization. +-c +-c IPNTR Integer array of length 14. (OUTPUT) +-c Pointer to mark the starting locations in the WORKD and WORKL +-c arrays for matrices/vectors used by the Arnoldi iteration. +-c ------------------------------------------------------------- +-c IPNTR(1): pointer to the current operand vector X in WORKD. +-c IPNTR(2): pointer to the current result vector Y in WORKD. +-c IPNTR(3): pointer to the vector B * X in WORKD when used in +-c the shift-and-invert mode. +-c IPNTR(4): pointer to the next available location in WORKL +-c that is untouched by the program. +-c IPNTR(5): pointer to the NCV by NCV upper Hessenberg +-c matrix H in WORKL. +-c IPNTR(6): pointer to the ritz value array RITZ +-c IPNTR(7): pointer to the (projected) ritz vector array Q +-c IPNTR(8): pointer to the error BOUNDS array in WORKL. +-c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. +-c +-c Note: IPNTR(9:13) is only referenced by zneupd . See Remark 2 below. +-c +-c IPNTR(9): pointer to the NCV RITZ values of the +-c original system. +-c IPNTR(10): Not Used +-c IPNTR(11): pointer to the NCV corresponding error bounds. +-c IPNTR(12): pointer to the NCV by NCV upper triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c zneupd if RVEC = .TRUE. See Remark 2 below. +-c +-c ------------------------------------------------------------- +-c +-c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) +-c Distributed array to be used in the basic Arnoldi iteration +-c for reverse communication. The user should not use WORKD +-c as temporary workspace during the iteration !!!!!!!!!! +-c See Data Distribution Note below. +-c +-c WORKL Complex*16 work array of length LWORKL. (OUTPUT/WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. See Data Distribution Note below. +-c +-c LWORKL Integer. (INPUT) +-c LWORKL must be at least 3*NCV**2 + 5*NCV. +-c +-c RWORK Double precision work array of length NCV (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c +-c INFO Integer. (INPUT/OUTPUT) +-c If INFO .EQ. 0, a randomly initial residual vector is used. +-c If INFO .NE. 0, RESID contains the initial residual vector, +-c possibly from a previous run. +-c Error flag on output. +-c = 0: Normal exit. +-c = 1: Maximum number of iterations taken. +-c All possible eigenvalues of OP has been found. IPARAM(5) +-c returns the number of wanted converged Ritz values. +-c = 2: No longer an informational error. Deprecated starting +-c with release 2 of ARPACK. +-c = 3: No shifts could be applied during a cycle of the +-c Implicitly restarted Arnoldi iteration. One possibility +-c is to increase the size of NCV relative to NEV. +-c See remark 4 below. +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 2 and less than or equal to N. +-c = -4: The maximum number of Arnoldi update iteration +-c must be greater than zero. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work array is not sufficient. +-c = -8: Error return from LAPACK eigenvalue calculation; +-c = -9: Starting vector is zero. +-c = -10: IPARAM(7) must be 1,2,3. +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: IPARAM(1) must be equal to 0 or 1. +-c = -9999: Could not build an Arnoldi factorization. +-c User input error highly likely. Please +-c check actual array dimensions and layout. +-c IPARAM(5) returns the size of the current Arnoldi +-c factorization. +-c +-c\Remarks +-c 1. The computed Ritz values are approximate eigenvalues of OP. The +-c selection of WHICH should be made with this in mind when using +-c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will +-c compute the NEV eigenvalues of the original problem that are +-c closest to the shift SIGMA . After convergence, approximate eigenvalues +-c of the original problem may be obtained with the ARPACK subroutine zneupd . +-c +-c 2. If a basis for the invariant subspace corresponding to the converged Ritz +-c values is needed, the user must call zneupd immediately following +-c completion of znaupd . This is new starting with release 2 of ARPACK. +-c +-c 3. If M can be factored into a Cholesky factorization M = LL` +-c then Mode = 2 should not be selected. Instead one should use +-c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular +-c linear systems should be solved with L and L` rather +-c than computing inverses. After convergence, an approximate +-c eigenvector z of the original problem is recovered by solving +-c L`z = x where x is a Ritz vector of OP. +-c +-c 4. At present there is no a-priori analysis to guide the selection +-c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. +-c However, it is recommended that NCV .ge. 2*NEV. If many problems of +-c the same type are to be solved, one should experiment with increasing +-c NCV while keeping NEV fixed for a given test problem. This will +-c usually decrease the required number of OP*x operations but it +-c also increases the work and storage required to maintain the orthogonal +-c basis vectors. The optimal "cross-over" with respect to CPU time +-c is problem dependent and must be determined empirically. +-c See Chapter 8 of Reference 2 for further information. +-c +-c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the +-c NP = IPARAM(8) complex shifts in locations +-c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). +-c Eigenvalues of the current upper Hessenberg matrix are located in +-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered +-c according to the order defined by WHICH. The associated Ritz estimates +-c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , +-c WORKL(IPNTR(8)+NCV-1). +-c +-c----------------------------------------------------------------------- +-c +-c\Data Distribution Note: +-c +-c Fortran-D syntax: +-c ================ +-c Complex*16 resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +-c decompose d1(n), d2(n,ncv) +-c align resid(i) with d1(i) +-c align v(i,j) with d2(i,j) +-c align workd(i) with d1(i) range (1:n) +-c align workd(i) with d1(i-n) range (n+1:2*n) +-c align workd(i) with d1(i-2*n) range (2*n+1:3*n) +-c distribute d1(block), d2(block,:) +-c replicated workl(lworkl) +-c +-c Cray MPP syntax: +-c =============== +-c Complex*16 resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) +-c shared resid(block), v(block,:), workd(block,:) +-c replicated workl(lworkl) +-c +-c CM2/CM5 syntax: +-c ============== +-c +-c----------------------------------------------------------------------- +-c +-c include 'ex-nonsym.doc' +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for +-c _Real_ Matrices", Linear Algebra and its Applications, vol 88/89, +-c pp 575-595, (1987). +-c +-c\Routines called: +-c znaup2 ARPACK routine that implements the Implicitly Restarted +-c Arnoldi Iteration. +-c zstatn ARPACK routine that initializes the timing variables. +-c ivout ARPACK utility routine that prints integers. +-c zvout ARPACK utility routine that prints vectors. +-c arscnd ARPACK utility routine for timing. +-c dlamch LAPACK routine that determines machine constants. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: naupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 +-c +-c\Remarks +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine znaupd +- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, +- & ipntr, workd, workl, lworkl, rwork, info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat*1, which*2 +- integer ido, info, ldv, lworkl, n, ncv, nev +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- Complex*16 +- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) +- Double precision +- & rwork(ncv) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) ) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer bounds, ierr, ih, iq, ishift, iupd, iw, +- & ldh, ldq, levec, mode, msglvl, mxiter, nb, +- & nev0, next, np, ritz, j +- save bounds, ih, iq, ishift, iupd, iw, +- & ldh, ldq, levec, mode, msglvl, mxiter, nb, +- & nev0, next, np, ritz +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external znaup2 , zvout , ivout, arscnd, zstatn +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dlamch +- external dlamch +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- if (ido .eq. 0) then +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call zstatn +- call arscnd (t0) +- msglvl = mcaupd +-c +-c %----------------% +-c | Error checking | +-c %----------------% +-c +- ierr = 0 +- ishift = iparam(1) +-c levec = iparam(2) +- mxiter = iparam(3) +-c nb = iparam(4) +- nb = 1 +-c +-c %--------------------------------------------% +-c | Revision 2 performs only implicit restart. | +-c %--------------------------------------------% +-c +- iupd = 1 +- mode = iparam(7) +-c +- if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev .or. ncv .gt. n) then +- ierr = -3 +- else if (mxiter .le. 0) then +- ierr = -4 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 5*ncv) then +- ierr = -7 +- else if (mode .lt. 1 .or. mode .gt. 3) then +- ierr = -10 +- else if (mode .eq. 1 .and. bmat .eq. 'G') then +- ierr = -11 +- end if +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- ido = 99 +- go to 9000 +- end if +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- if (nb .le. 0) nb = 1 +- if (tol .le. 0.0D+0 ) tol = dlamch ('EpsMach') +- if (ishift .ne. 0 .and. +- & ishift .ne. 1 .and. +- & ishift .ne. 2) ishift = 1 +-c +-c %----------------------------------------------% +-c | NP is the number of additional steps to | +-c | extend the length NEV Lanczos factorization. | +-c | NEV0 is the local variable designating the | +-c | size of the invariant subspace desired. | +-c %----------------------------------------------% +-c +- np = ncv - nev +- nev0 = nev +-c +-c %-----------------------------% +-c | Zero out internal workspace | +-c %-----------------------------% +-c +- do 10 j = 1, 3*ncv**2 + 5*ncv +- workl(j) = zero +- 10 continue +-c +-c %-------------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | +-c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | +-c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | +-c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | +-c | The final workspace is needed by subroutine zneigh called | +-c | by znaup2 . Subroutine zneigh calls LAPACK routines for | +-c | calculating eigenvalues and the last row of the eigenvector | +-c | matrix. | +-c %-------------------------------------------------------------% +-c +- ldh = ncv +- ldq = ncv +- ih = 1 +- ritz = ih + ldh*ncv +- bounds = ritz + ncv +- iq = bounds + ncv +- iw = iq + ldq*ncv +- next = iw + ncv**2 + 3*ncv +-c +- ipntr(4) = next +- ipntr(5) = ih +- ipntr(6) = ritz +- ipntr(7) = iq +- ipntr(8) = bounds +- ipntr(14) = iw +- end if +-c +-c %-------------------------------------------------------% +-c | Carry out the Implicitly restarted Arnoldi Iteration. | +-c %-------------------------------------------------------% +-c +- call znaup2 +- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, +- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), +- & workl(bounds), workl(iq), ldq, workl(iw), +- & ipntr, workd, rwork, info ) +-c +-c %--------------------------------------------------% +-c | ido .ne. 99 implies use of reverse communication | +-c | to compute operations involving OP. | +-c %--------------------------------------------------% +-c +- if (ido .eq. 3) iparam(8) = np +- if (ido .ne. 99) go to 9000 +-c +- iparam(3) = mxiter +- iparam(5) = np +- iparam(9) = nopx +- iparam(10) = nbx +- iparam(11) = nrorth +-c +-c %------------------------------------% +-c | Exit if there was an informational | +-c | error within znaup2 . | +-c %------------------------------------% +-c +- if (info .lt. 0) go to 9000 +- if (info .eq. 2) info = 3 +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [mxiter], ndigit, +- & '_naupd: Number of update iterations taken') +- call ivout (logfil, 1, [np], ndigit, +- & '_naupd: Number of wanted "converged" Ritz values') +- call zvout (logfil, np, workl(ritz), ndigit, +- & '_naupd: The final Ritz values') +- call zvout (logfil, np, workl(bounds), ndigit, +- & '_naupd: Associated Ritz estimates') +- end if +-c +- call arscnd (t1) +- tcaupd = t1 - t0 +-c +- if (msglvl .gt. 0) then +-c +-c %--------------------------------------------------------% +-c | Version Number & Version Date are defined in version.h | +-c %--------------------------------------------------------% +-c +- write (6,1000) +- write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, +- & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, +- & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec +- 1000 format (//, +- & 5x, '=============================================',/ +- & 5x, '= Complex implicit Arnoldi update code =',/ +- & 5x, '= Version Number: ', ' 2.3' , 21x, ' =',/ +- & 5x, '= Version Date: ', ' 07/31/96' , 16x, ' =',/ +- & 5x, '=============================================',/ +- & 5x, '= Summary of timing statistics =',/ +- & 5x, '=============================================',//) +- 1100 format ( +- & 5x, 'Total number update iterations = ', i5,/ +- & 5x, 'Total number of OP*x operations = ', i5,/ +- & 5x, 'Total number of B*x operations = ', i5,/ +- & 5x, 'Total number of reorthogonalization steps = ', i5,/ +- & 5x, 'Total number of iterative refinement steps = ', i5,/ +- & 5x, 'Total number of restart steps = ', i5,/ +- & 5x, 'Total time in user OP*x operation = ', f12.6,/ +- & 5x, 'Total time in user B*x operation = ', f12.6,/ +- & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ +- & 5x, 'Total time in naup2 routine = ', f12.6,/ +- & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ +- & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ +- & 5x, 'Total time in (re)start vector generation = ', f12.6,/ +- & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ +- & 5x, 'Total time in getting the shifts = ', f12.6,/ +- & 5x, 'Total time in applying the shifts = ', f12.6,/ +- & 5x, 'Total time in convergence testing = ', f12.6,/ +- & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of znaupd | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneigh.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneigh.f +deleted file mode 100644 +index db1bc22985..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneigh.f ++++ /dev/null +@@ -1,257 +0,0 @@ +-c\BeginDoc +-c +-c\Name: zneigh +-c +-c\Description: +-c Compute the eigenvalues of the current upper Hessenberg matrix +-c and the corresponding Ritz estimates given the current residual norm. +-c +-c\Usage: +-c call zneigh +-c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) +-c +-c\Arguments +-c RNORM Double precision scalar. (INPUT) +-c Residual norm corresponding to the current upper Hessenberg +-c matrix H. +-c +-c N Integer. (INPUT) +-c Size of the matrix H. +-c +-c H Complex*16 N by N array. (INPUT) +-c H contains the current upper Hessenberg matrix. +-c +-c LDH Integer. (INPUT) +-c Leading dimension of H exactly as declared in the calling +-c program. +-c +-c RITZ Complex*16 array of length N. (OUTPUT) +-c On output, RITZ(1:N) contains the eigenvalues of H. +-c +-c BOUNDS Complex*16 array of length N. (OUTPUT) +-c On output, BOUNDS contains the Ritz estimates associated with +-c the eigenvalues held in RITZ. This is equal to RNORM +-c times the last components of the eigenvectors corresponding +-c to the eigenvalues in RITZ. +-c +-c Q Complex*16 N by N array. (WORKSPACE) +-c Workspace needed to store the eigenvectors of H. +-c +-c LDQ Integer. (INPUT) +-c Leading dimension of Q exactly as declared in the calling +-c program. +-c +-c WORKL Complex*16 work array of length N**2 + 3*N. (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. This is needed to keep the full Schur form +-c of H and also in the calculation of the eigenvectors of H. +-c +-c RWORK Double precision work array of length N (WORKSPACE) +-c Private (replicated) array on each PE or array allocated on +-c the front end. +-c +-c IERR Integer. (OUTPUT) +-c Error exit flag from zlahqr or ztrevc. +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c zmout ARPACK utility routine that prints matrices +-c zvout ARPACK utility routine that prints vectors. +-c dvout ARPACK utility routine that prints vectors. +-c zlacpy LAPACK matrix copy routine. +-c zlahqr LAPACK routine to compute the Schur form of an +-c upper Hessenberg matrix. +-c zlaset LAPACK matrix initialization routine. +-c ztrevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper triangular form +-c zcopy Level 1 BLAS that copies one vector to another. +-c zdscal Level 1 BLAS that scales a complex vector by a real number. +-c dznrm2 Level 1 BLAS that computes the norm of a vector. +-c +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c None +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine zneigh (rnorm, n, h, ldh, ritz, bounds, +- & q, ldq, workl, rwork, ierr) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- integer ierr, n, ldh, ldq +- Double precision +- & rnorm +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex*16 +- & bounds(n), h(ldh,n), q(ldq,n), ritz(n), +- & workl(n*(n+3)) +- Double precision +- & rwork(n) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- Double precision +- & rone +- parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), +- & rone = 1.0D+0) +-c +-c %------------------------% +-c | Local Scalars & Arrays | +-c %------------------------% +-c +- logical select(1) +- integer j, msglvl +- Complex*16 +- & vl(1) +- Double precision +- & temp +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zlacpy, zlahqr, ztrevc, zcopy, +- & zdscal, zmout, zvout, arscnd +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dznrm2 +- external dznrm2 +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mceigh +-c +- if (msglvl .gt. 2) then +- call zmout (logfil, n, n, h, ldh, ndigit, +- & '_neigh: Entering upper Hessenberg matrix H ') +- end if +-c +-c %----------------------------------------------------------% +-c | 1. Compute the eigenvalues, the last components of the | +-c | corresponding Schur vectors and the full Schur form T | +-c | of the current upper Hessenberg matrix H. | +-c | zlahqr returns the full Schur form of H | +-c | in WORKL(1:N**2), and the Schur vectors in q. | +-c %----------------------------------------------------------% +-c +- call zlacpy ('All', n, n, h, ldh, workl, n) +- call zlaset ('All', n, n, zero, one, q, ldq) +- call zlahqr (.true., .true., n, 1, n, workl, ldh, ritz, +- & 1, n, q, ldq, ierr) +- if (ierr .ne. 0) go to 9000 +-c +- call zcopy (n, q(n-1,1), ldq, bounds, 1) +- if (msglvl .gt. 1) then +- call zvout (logfil, n, bounds, ndigit, +- & '_neigh: last row of the Schur matrix for H') +- end if +-c +-c %----------------------------------------------------------% +-c | 2. Compute the eigenvectors of the full Schur form T and | +-c | apply the Schur vectors to get the corresponding | +-c | eigenvectors. | +-c %----------------------------------------------------------% +-c +- call ztrevc ('Right', 'Back', select, n, workl, n, vl, n, q, +- & ldq, n, n, workl(n*n+1), rwork, ierr) +-c +- if (ierr .ne. 0) go to 9000 +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | Euclidean norms are all one. LAPACK subroutine | +-c | ztrevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1; here the magnitude of a complex | +-c | number (x,y) is taken to be |x| + |y|. | +-c %------------------------------------------------% +-c +- do 10 j=1, n +- temp = dznrm2( n, q(1,j), 1 ) +- call zdscal ( n, rone / temp, q(1,j), 1 ) +- 10 continue +-c +- if (msglvl .gt. 1) then +- call zcopy(n, q(n,1), ldq, workl, 1) +- call zvout (logfil, n, workl, ndigit, +- & '_neigh: Last row of the eigenvector matrix for H') +- end if +-c +-c %----------------------------% +-c | Compute the Ritz estimates | +-c %----------------------------% +-c +- call zcopy(n, q(n,1), n, bounds, 1) +- call zdscal(n, rnorm, bounds, 1) +-c +- if (msglvl .gt. 2) then +- call zvout (logfil, n, ritz, ndigit, +- & '_neigh: The eigenvalues of H') +- call zvout (logfil, n, bounds, ndigit, +- & '_neigh: Ritz estimates for the eigenvalues of H') +- end if +-c +- call arscnd(t1) +- tceigh = tceigh + (t1 - t0) +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of zneigh | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneupd.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneupd.f +deleted file mode 100644 +index 92e7dc9980..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zneupd.f ++++ /dev/null +@@ -1,876 +0,0 @@ +-c\BeginDoc +-c +-c\Name: zneupd +-c +-c\Description: +-c This subroutine returns the converged approximations to eigenvalues +-c of A*z = lambda*B*z and (optionally): +-c +-c (1) The corresponding approximate eigenvectors; +-c +-c (2) An orthonormal basis for the associated approximate +-c invariant subspace; +-c +-c (3) Both. +-c +-c There is negligible additional cost to obtain eigenvectors. An orthonormal +-c basis is always computed. There is an additional storage cost of n*nev +-c if both are requested (in this case a separate array Z must be supplied). +-c +-c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z +-c are derived from approximate eigenvalues and eigenvectors of +-c of the linear operator OP prescribed by the MODE selection in the +-c call to ZNAUPD. ZNAUPD must be called before this routine is called. +-c These approximate eigenvalues and vectors are commonly called Ritz +-c values and Ritz vectors respectively. They are referred to as such +-c in the comments that follow. The computed orthonormal basis for the +-c invariant subspace corresponding to these Ritz values is referred to as a +-c Schur basis. +-c +-c The definition of OP as well as other terms and the relation of computed +-c Ritz values and vectors of OP with respect to the given problem +-c A*z = lambda*B*z may be found in the header of ZNAUPD. For a brief +-c description, see definitions of IPARAM(7), MODE and WHICH in the +-c documentation of ZNAUPD. +-c +-c\Usage: +-c call zneupd +-c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, +-c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, +-c WORKL, LWORKL, RWORK, INFO ) +-c +-c\Arguments: +-c RVEC LOGICAL (INPUT) +-c Specifies whether a basis for the invariant subspace corresponding +-c to the converged Ritz value approximations for the eigenproblem +-c A*z = lambda*B*z is computed. +-c +-c RVEC = .FALSE. Compute Ritz values only. +-c +-c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. +-c See Remarks below. +-c +-c HOWMNY Character*1 (INPUT) +-c Specifies the form of the basis for the invariant subspace +-c corresponding to the converged Ritz values that is to be computed. +-c +-c = 'A': Compute NEV Ritz vectors; +-c = 'P': Compute NEV Schur vectors; +-c = 'S': compute some of the Ritz vectors, specified +-c by the logical array SELECT. +-c +-c SELECT Logical array of dimension NCV. (INPUT) +-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be +-c computed. To select the Ritz vector corresponding to a +-c Ritz value D(j), SELECT(j) must be set to .TRUE.. +-c If HOWMNY = 'A' or 'P', SELECT need not be initialized +-c but it is used as internal workspace. +-c +-c D Complex*16 array of dimension NEV+1. (OUTPUT) +-c On exit, D contains the Ritz approximations +-c to the eigenvalues lambda for A*z = lambda*B*z. +-c +-c Z Complex*16 N by NEV array (OUTPUT) +-c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of +-c Z represents approximate eigenvectors (Ritz vectors) corresponding +-c to the NCONV=IPARAM(5) Ritz values for eigensystem +-c A*z = lambda*B*z. +-c +-c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. +-c +-c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, +-c the array Z may be set equal to first NEV+1 columns of the Arnoldi +-c basis array V computed by ZNAUPD. In this case the Arnoldi basis +-c will be destroyed and overwritten with the eigenvector basis. +-c +-c LDZ Integer. (INPUT) +-c The leading dimension of the array Z. If Ritz vectors are +-c desired, then LDZ .ge. max( 1, N ) is required. +-c In any case, LDZ .ge. 1 is required. +-c +-c SIGMA Complex*16 (INPUT) +-c If IPARAM(7) = 3 then SIGMA represents the shift. +-c Not referenced if IPARAM(7) = 1 or 2. +-c +-c WORKEV Complex*16 work array of dimension 2*NCV. (WORKSPACE) +-c +-c **** The remaining arguments MUST be the same as for the **** +-c **** call to ZNAUPD that was just completed. **** +-c +-c NOTE: The remaining arguments +-c +-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, +-c WORKD, WORKL, LWORKL, RWORK, INFO +-c +-c must be passed directly to ZNEUPD following the last call +-c to ZNAUPD. These arguments MUST NOT BE MODIFIED between +-c the the last call to ZNAUPD and the call to ZNEUPD. +-c +-c Three of these parameters (V, WORKL and INFO) are also output parameters: +-c +-c V Complex*16 N by NCV array. (INPUT/OUTPUT) +-c +-c Upon INPUT: the NCV columns of V contain the Arnoldi basis +-c vectors for OP as constructed by ZNAUPD . +-c +-c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns +-c contain approximate Schur vectors that span the +-c desired invariant subspace. +-c +-c NOTE: If the array Z has been set equal to first NEV+1 columns +-c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the +-c Arnoldi basis held by V has been overwritten by the desired +-c Ritz vectors. If a separate array Z has been passed then +-c the first NCONV=IPARAM(5) columns of V will contain approximate +-c Schur vectors that span the desired invariant subspace. +-c +-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) +-c WORKL(1:ncv*ncv+2*ncv) contains information obtained in +-c znaupd. They are not changed by zneupd. +-c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the +-c untransformed Ritz values, the untransformed error estimates of +-c the Ritz values, the upper triangular matrix for H, and the +-c associated matrix representation of the invariant subspace for H. +-c +-c Note: IPNTR(9:13) contains the pointer into WORKL for addresses +-c of the above information computed by zneupd. +-c ------------------------------------------------------------- +-c IPNTR(9): pointer to the NCV RITZ values of the +-c original system. +-c IPNTR(10): Not used +-c IPNTR(11): pointer to the NCV corresponding error estimates. +-c IPNTR(12): pointer to the NCV by NCV upper triangular +-c Schur matrix for H. +-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors +-c of the upper Hessenberg matrix H. Only referenced by +-c zneupd if RVEC = .TRUE. See Remark 2 below. +-c ------------------------------------------------------------- +-c +-c INFO Integer. (OUTPUT) +-c Error flag on output. +-c = 0: Normal exit. +-c +-c = 1: The Schur form computed by LAPACK routine csheqr +-c could not be reordered by LAPACK routine ztrsen. +-c Re-enter subroutine zneupd with IPARAM(5)=NCV and +-c increase the size of the array D to have +-c dimension at least dimension NCV and allocate at least NCV +-c columns for Z. NOTE: Not necessary if Z and V share +-c the same space. Please notify the authors if this error +-c occurs. +-c +-c = -1: N must be positive. +-c = -2: NEV must be positive. +-c = -3: NCV-NEV >= 1 and less than or equal to N. +-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' +-c = -6: BMAT must be one of 'I' or 'G'. +-c = -7: Length of private work WORKL array is not sufficient. +-c = -8: Error return from LAPACK eigenvalue calculation. +-c This should never happened. +-c = -9: Error return from calculation of eigenvectors. +-c Informational error from LAPACK routine ztrevc. +-c = -10: IPARAM(7) must be 1,2,3 +-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. +-c = -12: HOWMNY = 'S' not yet implemented +-c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. +-c = -14: ZNAUPD did not find any eigenvalues to sufficient +-c accuracy. +-c = -15: ZNEUPD got a different count of the number of converged +-c Ritz values than ZNAUPD got. This indicates the user +-c probably made an error in passing data from ZNAUPD to +-c ZNEUPD or that the data was modified before entering +-c ZNEUPD +-c +-c\BeginLib +-c +-c\References: +-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in +-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), +-c pp 357-385. +-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly +-c Restarted Arnoldi Iteration", Rice University Technical Report +-c TR95-13, Department of Computational and Applied Mathematics. +-c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, +-c "How to Implement the Spectral Transformation", Math Comp., +-c Vol. 48, No. 178, April, 1987 pp. 664-673. +-c +-c\Routines called: +-c ivout ARPACK utility routine that prints integers. +-c zmout ARPACK utility routine that prints matrices +-c zvout ARPACK utility routine that prints vectors. +-c zgeqr2 LAPACK routine that computes the QR factorization of +-c a matrix. +-c zlacpy LAPACK matrix copy routine. +-c zlahqr LAPACK routine that computes the Schur form of a +-c upper Hessenberg matrix. +-c zlaset LAPACK matrix initialization routine. +-c ztrevc LAPACK routine to compute the eigenvectors of a matrix +-c in upper triangular form. +-c ztrsen LAPACK routine that re-orders the Schur form. +-c zunm2r LAPACK routine that applies an orthogonal matrix in +-c factored form. +-c dlamch LAPACK routine that determines machine constants. +-c ztrmm Level 3 BLAS matrix times an upper triangular matrix. +-c zgeru Level 2 BLAS rank one update to a matrix. +-c zcopy Level 1 BLAS that copies one vector to another . +-c zscal Level 1 BLAS that scales a vector. +-c zdscal Level 1 BLAS that scales a complex vector by a real number. +-c dznrm2 Level 1 BLAS that computes the norm of a complex vector. +-c +-c\Remarks +-c +-c 1. Currently only HOWMNY = 'A' and 'P' are implemented. +-c +-c 2. Schur vectors are an orthogonal representation for the basis of +-c Ritz vectors. Thus, their numerical properties are often superior. +-c If RVEC = .true. then the relationship +-c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and +-c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I +-c are approximately satisfied. +-c Here T is the leading submatrix of order IPARAM(5) of the +-c upper triangular matrix stored workl(ipntr(12)). +-c +-c\Authors +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Chao Yang Houston, Texas +-c Dept. of Computational & +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +- subroutine zneupd(rvec , howmny, select, d , +- & z , ldz , sigma , workev, +- & bmat , n , which , nev , +- & tol , resid , ncv , v , +- & ldv , iparam, ipntr , workd , +- & workl, lworkl, rwork , info ) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character bmat, howmny, which*2 +- logical rvec +- integer info, ldz, ldv, lworkl, n, ncv, nev +- Complex*16 +- & sigma +- Double precision +- & tol +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- integer iparam(11), ipntr(14) +- logical select(ncv) +- Double precision +- & rwork(ncv) +- Complex*16 +- & d(nev) , resid(n) , v(ldv,ncv), +- & z(ldz, nev), +- & workd(3*n) , workl(lworkl), workev(2*ncv) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- character type*6 +- integer bounds, ierr , ih , ihbds, iheig , nconv , +- & invsub, iuptri, iwev , j , ldh , ldq , +- & mode , msglvl, ritz , wr , k , irz , +- & ibd , outncv, iq , np , numcnv, jj , +- & ishift, nconv2 +- Complex*16 +- & rnorm, temp, vl(1) +- Double precision +- & conds, sep, rtemp, eps23 +- logical reord +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zcopy , zgeru, zgeqr2, zlacpy, zmout, +- & zunm2r, ztrmm, zvout, ivout, +- & zlahqr +-c +-c %--------------------% +-c | External Functions | +-c %--------------------% +-c +- Double precision +- & dznrm2, dlamch, dlapy2 +- external dznrm2, dlamch, dlapy2 +-c +- Complex*16 +- & zzdotc +- external zzdotc +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %------------------------% +-c | Set default parameters | +-c %------------------------% +-c +- msglvl = mceupd +- mode = iparam(7) +- nconv = iparam(5) +- info = 0 +-c +-c +-c %---------------------------------% +-c | Get machine dependent constant. | +-c %---------------------------------% +-c +- eps23 = dlamch('Epsilon-Machine') +- eps23 = eps23**(2.0D+0 / 3.0D+0) +-c +-c %-------------------------------% +-c | Quick return | +-c | Check for incompatible input | +-c %-------------------------------% +-c +- ierr = 0 +-c +- if (nconv .le. 0) then +- ierr = -14 +- else if (n .le. 0) then +- ierr = -1 +- else if (nev .le. 0) then +- ierr = -2 +- else if (ncv .le. nev+1 .or. ncv .gt. n) then +- ierr = -3 +- else if (which .ne. 'LM' .and. +- & which .ne. 'SM' .and. +- & which .ne. 'LR' .and. +- & which .ne. 'SR' .and. +- & which .ne. 'LI' .and. +- & which .ne. 'SI') then +- ierr = -5 +- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then +- ierr = -6 +- else if (lworkl .lt. 3*ncv**2 + 4*ncv) then +- ierr = -7 +- else if ( (howmny .ne. 'A' .and. +- & howmny .ne. 'P' .and. +- & howmny .ne. 'S') .and. rvec ) then +- ierr = -13 +- else if (howmny .eq. 'S' ) then +- ierr = -12 +- end if +-c +- if (mode .eq. 1 .or. mode .eq. 2) then +- type = 'REGULR' +- else if (mode .eq. 3 ) then +- type = 'SHIFTI' +- else +- ierr = -10 +- end if +- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 +-c +-c %------------% +-c | Error Exit | +-c %------------% +-c +- if (ierr .ne. 0) then +- info = ierr +- go to 9000 +- end if +-c +-c %--------------------------------------------------------% +-c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | +-c | etc... and the remaining workspace. | +-c | Also update pointer to be used on output. | +-c | Memory is laid out as follows: | +-c | workl(1:ncv*ncv) := generated Hessenberg matrix | +-c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | +-c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | +-c %--------------------------------------------------------% +-c +-c %-----------------------------------------------------------% +-c | The following is used and set by ZNEUPD. | +-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | +-c | Ritz values. | +-c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | +-c | error bounds of | +-c | the Ritz values | +-c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | +-c | triangular matrix | +-c | for H. | +-c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | +-c | associated matrix | +-c | representation of | +-c | the invariant | +-c | subspace for H. | +-c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | +-c %-----------------------------------------------------------% +-c +- ih = ipntr(5) +- ritz = ipntr(6) +- iq = ipntr(7) +- bounds = ipntr(8) +- ldh = ncv +- ldq = ncv +- iheig = bounds + ldh +- ihbds = iheig + ldh +- iuptri = ihbds + ldh +- invsub = iuptri + ldh*ncv +- ipntr(9) = iheig +- ipntr(11) = ihbds +- ipntr(12) = iuptri +- ipntr(13) = invsub +- wr = 1 +- iwev = wr + ncv +-c +-c %-----------------------------------------% +-c | irz points to the Ritz values computed | +-c | by _neigh before exiting _naup2. | +-c | ibd points to the Ritz estimates | +-c | computed by _neigh before exiting | +-c | _naup2. | +-c %-----------------------------------------% +-c +- irz = ipntr(14) + ncv*ncv +- ibd = irz + ncv +-c +-c %------------------------------------% +-c | RNORM is B-norm of the RESID(1:N). | +-c %------------------------------------% +-c +- rnorm = workl(ih+2) +- workl(ih+2) = zero +-c +- if (msglvl .gt. 2) then +- call zvout(logfil, ncv, workl(irz), ndigit, +- & '_neupd: Ritz values passed in from _NAUPD.') +- call zvout(logfil, ncv, workl(ibd), ndigit, +- & '_neupd: Ritz estimates passed in from _NAUPD.') +- end if +-c +- if (rvec) then +-c +- reord = .false. +-c +-c %---------------------------------------------------% +-c | Use the temporary bounds array to store indices | +-c | These will be used to mark the select array later | +-c %---------------------------------------------------% +-c +- do 10 j = 1,ncv +- workl(bounds+j-1) = j +- select(j) = .false. +- 10 continue +-c +-c %-------------------------------------% +-c | Select the wanted Ritz values. | +-c | Sort the Ritz values so that the | +-c | wanted ones appear at the tailing | +-c | NEV positions of workl(irr) and | +-c | workl(iri). Move the corresponding | +-c | error estimates in workl(ibd) | +-c | accordingly. | +-c %-------------------------------------% +-c +- np = ncv - nev +- ishift = 0 +- call zngets(ishift, which , nev , +- & np , workl(irz), workl(bounds)) +-c +- if (msglvl .gt. 2) then +- call zvout (logfil, ncv, workl(irz), ndigit, +- & '_neupd: Ritz values after calling _NGETS.') +- call zvout (logfil, ncv, workl(bounds), ndigit, +- & '_neupd: Ritz value indices after calling _NGETS.') +- end if +-c +-c %-----------------------------------------------------% +-c | Record indices of the converged wanted Ritz values | +-c | Mark the select array for possible reordering | +-c %-----------------------------------------------------% +-c +- numcnv = 0 +- do 11 j = 1,ncv +- rtemp = max(eps23, +- & dlapy2 ( dble(workl(irz+ncv-j)), +- & aimag(workl(irz+ncv-j)) )) +- jj = workl(bounds + ncv - j) +- if (numcnv .lt. nconv .and. +- & dlapy2( dble(workl(ibd+jj-1)), +- & aimag(workl(ibd+jj-1)) ) +- & .le. tol*rtemp) then +- select(jj) = .true. +- numcnv = numcnv + 1 +- if (jj .gt. nconv) reord = .true. +- endif +- 11 continue +-c +-c %-----------------------------------------------------------% +-c | Check the count (numcnv) of converged Ritz values with | +-c | the number (nconv) reported by dnaupd. If these two | +-c | are different then there has probably been an error | +-c | caused by incorrect passing of the dnaupd data. | +-c %-----------------------------------------------------------% +-c +- if (msglvl .gt. 2) then +- call ivout(logfil, 1, [numcnv], ndigit, +- & '_neupd: Number of specified eigenvalues') +- call ivout(logfil, 1, [nconv], ndigit, +- & '_neupd: Number of "converged" eigenvalues') +- end if +-c +- if (numcnv .ne. nconv) then +- info = -15 +- go to 9000 +- end if +-c +-c %-------------------------------------------------------% +-c | Call LAPACK routine zlahqr to compute the Schur form | +-c | of the upper Hessenberg matrix returned by ZNAUPD. | +-c | Make a copy of the upper Hessenberg matrix. | +-c | Initialize the Schur vector matrix Q to the identity. | +-c %-------------------------------------------------------% +-c +- call zcopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) +- call zlaset('All', ncv, ncv , +- & zero , one, workl(invsub), +- & ldq) +- call zlahqr(.true., .true. , ncv , +- & 1 , ncv , workl(iuptri), +- & ldh , workl(iheig) , 1 , +- & ncv , workl(invsub), ldq , +- & ierr) +- call zcopy(ncv , workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +-c +- if (ierr .ne. 0) then +- info = -8 +- go to 9000 +- end if +-c +- if (msglvl .gt. 1) then +- call zvout (logfil, ncv, workl(iheig), ndigit, +- & '_neupd: Eigenvalues of H') +- call zvout (logfil, ncv, workl(ihbds), ndigit, +- & '_neupd: Last row of the Schur vector matrix') +- if (msglvl .gt. 3) then +- call zmout (logfil , ncv, ncv , +- & workl(iuptri), ldh, ndigit, +- & '_neupd: The upper triangular matrix ') +- end if +- end if +-c +- if (reord) then +-c +-c %-----------------------------------------------% +-c | Reorder the computed upper triangular matrix. | +-c %-----------------------------------------------% +-c +- call ztrsen('None' , 'V' , select , +- & ncv , workl(iuptri), ldh , +- & workl(invsub), ldq , workl(iheig), +- & nconv2 , conds , sep , +- & workev , ncv , ierr) +-c +- if (nconv2 .lt. nconv) then +- nconv = nconv2 +- end if +- +- if (ierr .eq. 1) then +- info = 1 +- go to 9000 +- end if +-c +- if (msglvl .gt. 2) then +- call zvout (logfil, ncv, workl(iheig), ndigit, +- & '_neupd: Eigenvalues of H--reordered') +- if (msglvl .gt. 3) then +- call zmout(logfil , ncv, ncv , +- & workl(iuptri), ldq, ndigit, +- & '_neupd: Triangular matrix after re-ordering') +- end if +- end if +-c +- end if +-c +-c %---------------------------------------------% +-c | Copy the last row of the Schur basis matrix | +-c | to workl(ihbds). This vector will be used | +-c | to compute the Ritz estimates of converged | +-c | Ritz values. | +-c %---------------------------------------------% +-c +- call zcopy(ncv , workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +-c +-c %--------------------------------------------% +-c | Place the computed eigenvalues of H into D | +-c | if a spectral transformation was not used. | +-c %--------------------------------------------% +-c +- if (type .eq. 'REGULR') then +- call zcopy(nconv, workl(iheig), 1, d, 1) +- end if +-c +-c %----------------------------------------------------------% +-c | Compute the QR factorization of the matrix representing | +-c | the wanted invariant subspace located in the first NCONV | +-c | columns of workl(invsub,ldq). | +-c %----------------------------------------------------------% +-c +- call zgeqr2(ncv , nconv , workl(invsub), +- & ldq , workev, workev(ncv+1), +- & ierr) +-c +-c %--------------------------------------------------------% +-c | * Postmultiply V by Q using zunm2r. | +-c | * Copy the first NCONV columns of VQ into Z. | +-c | * Postmultiply Z by R. | +-c | The N by NCONV matrix Z is now a matrix representation | +-c | of the approximate invariant subspace associated with | +-c | the Ritz values in workl(iheig). The first NCONV | +-c | columns of V are now approximate Schur vectors | +-c | associated with the upper triangular matrix of order | +-c | NCONV in workl(iuptri). | +-c %--------------------------------------------------------% +-c +- call zunm2r('Right', 'Notranspose', n , +- & ncv , nconv , workl(invsub), +- & ldq , workev , v , +- & ldv , workd(n+1) , ierr) +- call zlacpy('All', n, nconv, v, ldv, z, ldz) +-c +- do 20 j=1, nconv +-c +-c %---------------------------------------------------% +-c | Perform both a column and row scaling if the | +-c | diagonal element of workl(invsub,ldq) is negative | +-c | I'm lazy and don't take advantage of the upper | +-c | triangular form of workl(iuptri,ldq). | +-c | Note that since Q is orthogonal, R is a diagonal | +-c | matrix consisting of plus or minus ones. | +-c %---------------------------------------------------% +-c +- if ( dble( workl(invsub+(j-1)*ldq+j-1) ) .lt. +- & dble(zero) ) then +- call zscal(nconv, -one, workl(iuptri+j-1), ldq) +- call zscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) +- end if +-c +- 20 continue +-c +- if (howmny .eq. 'A') then +-c +-c %--------------------------------------------% +-c | Compute the NCONV wanted eigenvectors of T | +-c | located in workl(iuptri,ldq). | +-c %--------------------------------------------% +-c +- do 30 j=1, ncv +- if (j .le. nconv) then +- select(j) = .true. +- else +- select(j) = .false. +- end if +- 30 continue +-c +- call ztrevc('Right', 'Select' , select , +- & ncv , workl(iuptri), ldq , +- & vl , 1 , workl(invsub), +- & ldq , ncv , outncv , +- & workev , rwork , ierr) +-c +- if (ierr .ne. 0) then +- info = -9 +- go to 9000 +- end if +-c +-c %------------------------------------------------% +-c | Scale the returning eigenvectors so that their | +-c | Euclidean norms are all one. LAPACK subroutine | +-c | ztrevc returns each eigenvector normalized so | +-c | that the element of largest magnitude has | +-c | magnitude 1. | +-c %------------------------------------------------% +-c +- do 40 j=1, nconv +- rtemp = dznrm2(ncv, workl(invsub+(j-1)*ldq), 1) +- rtemp = dble(one) / rtemp +- call zdscal ( ncv, rtemp, +- & workl(invsub+(j-1)*ldq), 1 ) +-c +-c %------------------------------------------% +-c | Ritz estimates can be obtained by taking | +-c | the inner product of the last row of the | +-c | Schur basis of H with eigenvectors of T. | +-c | Note that the eigenvector matrix of T is | +-c | upper triangular, thus the length of the | +-c | inner product can be set to j. | +-c %------------------------------------------% +-c +- workev(j) = zzdotc(j, workl(ihbds), 1, +- & workl(invsub+(j-1)*ldq), 1) +- 40 continue +-c +- if (msglvl .gt. 2) then +- call zcopy(nconv, workl(invsub+ncv-1), ldq, +- & workl(ihbds), 1) +- call zvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Last row of the eigenvector matrix for T') +- if (msglvl .gt. 3) then +- call zmout(logfil , ncv, ncv , +- & workl(invsub), ldq, ndigit, +- & '_neupd: The eigenvector matrix for T') +- end if +- end if +-c +-c %---------------------------------------% +-c | Copy Ritz estimates into workl(ihbds) | +-c %---------------------------------------% +-c +- call zcopy(nconv, workev, 1, workl(ihbds), 1) +-c +-c %----------------------------------------------% +-c | The eigenvector matrix Q of T is triangular. | +-c | Form Z*Q. | +-c %----------------------------------------------% +-c +- call ztrmm('Right' , 'Upper' , 'No transpose', +- & 'Non-unit', n , nconv , +- & one , workl(invsub), ldq , +- & z , ldz) +- end if +-c +- else +-c +-c %--------------------------------------------------% +-c | An approximate invariant subspace is not needed. | +-c | Place the Ritz values computed ZNAUPD into D. | +-c %--------------------------------------------------% +-c +- call zcopy(nconv, workl(ritz), 1, d, 1) +- call zcopy(nconv, workl(ritz), 1, workl(iheig), 1) +- call zcopy(nconv, workl(bounds), 1, workl(ihbds), 1) +-c +- end if +-c +-c %------------------------------------------------% +-c | Transform the Ritz values and possibly vectors | +-c | and corresponding error bounds of OP to those | +-c | of A*x = lambda*B*x. | +-c %------------------------------------------------% +-c +- if (type .eq. 'REGULR') then +-c +- if (rvec) +- & call zscal(ncv, rnorm, workl(ihbds), 1) +-c +- else +-c +-c %---------------------------------------% +-c | A spectral transformation was used. | +-c | * Determine the Ritz estimates of the | +-c | Ritz values in the original system. | +-c %---------------------------------------% +-c +- if (rvec) +- & call zscal(ncv, rnorm, workl(ihbds), 1) +-c +- do 50 k=1, ncv +- temp = workl(iheig+k-1) +- workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp +- 50 continue +-c +- end if +-c +-c %-----------------------------------------------------------% +-c | * Transform the Ritz values back to the original system. | +-c | For TYPE = 'SHIFTI' the transformation is | +-c | lambda = 1/theta + sigma | +-c | NOTES: | +-c | *The Ritz vectors are not affected by the transformation. | +-c %-----------------------------------------------------------% +-c +- if (type .eq. 'SHIFTI') then +- do 60 k=1, nconv +- d(k) = one / workl(iheig+k-1) + sigma +- 60 continue +- end if +-c +- if (type .ne. 'REGULR' .and. msglvl .gt. 1) then +- call zvout (logfil, nconv, d, ndigit, +- & '_neupd: Untransformed Ritz values.') +- call zvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Ritz estimates of the untransformed Ritz values.') +- else if ( msglvl .gt. 1) then +- call zvout (logfil, nconv, d, ndigit, +- & '_neupd: Converged Ritz values.') +- call zvout (logfil, nconv, workl(ihbds), ndigit, +- & '_neupd: Associated Ritz estimates.') +- end if +-c +-c %-------------------------------------------------% +-c | Eigenvector Purification step. Formally perform | +-c | one of inverse subspace iteration. Only used | +-c | for MODE = 3. See reference 3. | +-c %-------------------------------------------------% +-c +- if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then +-c +-c %------------------------------------------------% +-c | Purify the computed Ritz vectors by adding a | +-c | little bit of the residual vector: | +-c | T | +-c | resid(:)*( e s ) / theta | +-c | NCV | +-c | where H s = s theta. | +-c %------------------------------------------------% +-c +- do 100 j=1, nconv +- if (workl(iheig+j-1) .ne. zero) then +- workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / +- & workl(iheig+j-1) +- endif +- 100 continue +- +-c %---------------------------------------% +-c | Perform a rank one update to Z and | +-c | purify all the Ritz vectors together. | +-c %---------------------------------------% +-c +- call zgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) +-c +- end if +-c +- 9000 continue +-c +- return +-c +-c %---------------% +-c | End of zneupd| +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zngets.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zngets.f +deleted file mode 100644 +index e7d2433492..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zngets.f ++++ /dev/null +@@ -1,178 +0,0 @@ +-c\BeginDoc +-c +-c\Name: zngets +-c +-c\Description: +-c Given the eigenvalues of the upper Hessenberg matrix H, +-c computes the NP shifts AMU that are zeros of the polynomial of +-c degree NP which filters out components of the unwanted eigenvectors +-c corresponding to the AMU's based on some given criteria. +-c +-c NOTE: call this even in the case of user specified shifts in order +-c to sort the eigenvalues, and error bounds of H for later use. +-c +-c\Usage: +-c call zngets +-c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) +-c +-c\Arguments +-c ISHIFT Integer. (INPUT) +-c Method for selecting the implicit shifts at each iteration. +-c ISHIFT = 0: user specified shifts +-c ISHIFT = 1: exact shift with respect to the matrix H. +-c +-c WHICH Character*2. (INPUT) +-c Shift selection criteria. +-c 'LM' -> want the KEV eigenvalues of largest magnitude. +-c 'SM' -> want the KEV eigenvalues of smallest magnitude. +-c 'LR' -> want the KEV eigenvalues of largest REAL part. +-c 'SR' -> want the KEV eigenvalues of smallest REAL part. +-c 'LI' -> want the KEV eigenvalues of largest imaginary part. +-c 'SI' -> want the KEV eigenvalues of smallest imaginary part. +-c +-c KEV Integer. (INPUT) +-c The number of desired eigenvalues. +-c +-c NP Integer. (INPUT) +-c The number of shifts to compute. +-c +-c RITZ Complex*16 array of length KEV+NP. (INPUT/OUTPUT) +-c On INPUT, RITZ contains the the eigenvalues of H. +-c On OUTPUT, RITZ are sorted so that the unwanted +-c eigenvalues are in the first NP locations and the wanted +-c portion is in the last KEV locations. When exact shifts are +-c selected, the unwanted part corresponds to the shifts to +-c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues +-c are further sorted so that the ones with largest Ritz values +-c are first. +-c +-c BOUNDS Complex*16 array of length KEV+NP. (INPUT/OUTPUT) +-c Error bounds corresponding to the ordering in RITZ. +-c +-c +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Local variables: +-c xxxxxx Complex*16 +-c +-c\Routines called: +-c zsortc ARPACK sorting routine. +-c ivout ARPACK utility routine that prints integers. +-c arscnd ARPACK utility routine for timing. +-c zvout ARPACK utility routine that prints vectors. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c\SCCS Information: @(#) +-c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\Remarks +-c 1. This routine does not keep complex conjugate pairs of +-c eigenvalues together. +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine zngets ( ishift, which, kev, np, ritz, bounds) +-c +-c %----------------------------------------------------% +-c | Include files for debugging and timing information | +-c %----------------------------------------------------% +-c +- include 'debug.h' +- include 'stat.h' +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- integer ishift, kev, np +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex*16 +- & bounds(kev+np), ritz(kev+np) +-c +-c %------------% +-c | Parameters | +-c %------------% +-c +- Complex*16 +- & one, zero +- parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer msglvl +-c +-c %----------------------% +-c | External Subroutines | +-c %----------------------% +-c +- external zvout, zsortc, arscnd +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +-c %-------------------------------% +-c | Initialize timing statistics | +-c | & message level for debugging | +-c %-------------------------------% +-c +- call arscnd (t0) +- msglvl = mcgets +-c +- call zsortc (which, .true., kev+np, ritz, bounds) +-c +- if ( ishift .eq. 1 ) then +-c +-c %-------------------------------------------------------% +-c | Sort the unwanted Ritz values used as shifts so that | +-c | the ones with largest Ritz estimates are first | +-c | This will tend to minimize the effects of the | +-c | forward instability of the iteration when the shifts | +-c | are applied in subroutine znapps. | +-c | Be careful and use 'SM' since we want to sort BOUNDS! | +-c %-------------------------------------------------------% +-c +- call zsortc ( 'SM', .true., np, bounds, ritz ) +-c +- end if +-c +- call arscnd (t1) +- tcgets = tcgets + (t1 - t0) +-c +- if (msglvl .gt. 0) then +- call ivout (logfil, 1, [kev], ndigit, '_ngets: KEV is') +- call ivout (logfil, 1, [np], ndigit, '_ngets: NP is') +- call zvout (logfil, kev+np, ritz, ndigit, +- & '_ngets: Eigenvalues of current H matrix ') +- call zvout (logfil, kev+np, bounds, ndigit, +- & '_ngets: Ritz estimates of the current KEV+NP Ritz values') +- end if +-c +- return +-c +-c %---------------% +-c | End of zngets | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zsortc.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zsortc.f +deleted file mode 100644 +index 6ea37a42f7..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zsortc.f ++++ /dev/null +@@ -1,322 +0,0 @@ +-c\BeginDoc +-c +-c\Name: zsortc +-c +-c\Description: +-c Sorts the Complex*16 array in X into the order +-c specified by WHICH and optionally applies the permutation to the +-c Double precision array Y. +-c +-c\Usage: +-c call zsortc +-c ( WHICH, APPLY, N, X, Y ) +-c +-c\Arguments +-c WHICH Character*2. (Input) +-c 'LM' -> sort X into increasing order of magnitude. +-c 'SM' -> sort X into decreasing order of magnitude. +-c 'LR' -> sort X with real(X) in increasing algebraic order +-c 'SR' -> sort X with real(X) in decreasing algebraic order +-c 'LI' -> sort X with imag(X) in increasing algebraic order +-c 'SI' -> sort X with imag(X) in decreasing algebraic order +-c +-c APPLY Logical. (Input) +-c APPLY = .TRUE. -> apply the sorted order to array Y. +-c APPLY = .FALSE. -> do not apply the sorted order to array Y. +-c +-c N Integer. (INPUT) +-c Size of the arrays. +-c +-c X Complex*16 array of length N. (INPUT/OUTPUT) +-c This is the array to be sorted. +-c +-c Y Complex*16 array of length N. (INPUT/OUTPUT) +-c +-c\EndDoc +-c +-c----------------------------------------------------------------------- +-c +-c\BeginLib +-c +-c\Routines called: +-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. +-c +-c\Author +-c Danny Sorensen Phuong Vu +-c Richard Lehoucq CRPC / Rice University +-c Dept. of Computational & Houston, Texas +-c Applied Mathematics +-c Rice University +-c Houston, Texas +-c +-c Adapted from the sort routine in LANSO. +-c +-c\SCCS Information: @(#) +-c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c\EndLib +-c +-c----------------------------------------------------------------------- +-c +- subroutine zsortc (which, apply, n, x, y) +-c +-c %------------------% +-c | Scalar Arguments | +-c %------------------% +-c +- character*2 which +- logical apply +- integer n +-c +-c %-----------------% +-c | Array Arguments | +-c %-----------------% +-c +- Complex*16 +- & x(0:n-1), y(0:n-1) +-c +-c %---------------% +-c | Local Scalars | +-c %---------------% +-c +- integer i, igap, j +- Complex*16 +- & temp +- Double precision +- & temp1, temp2 +-c +-c %--------------------% +-c | External functions | +-c %--------------------% +-c +- Double precision +- & dlapy2 +-c +-c %--------------------% +-c | Intrinsic Functions | +-c %--------------------% +- Intrinsic +- & dble, aimag +-c +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +-c +- igap = n / 2 +-c +- if (which .eq. 'LM') then +-c +-c %--------------------------------------------% +-c | Sort X into increasing order of magnitude. | +-c %--------------------------------------------% +-c +- 10 continue +- if (igap .eq. 0) go to 9000 +-c +- do 30 i = igap, n-1 +- j = i-igap +- 20 continue +-c +- if (j.lt.0) go to 30 +-c +- temp1 = dlapy2(dble(x(j)),aimag(x(j))) +- temp2 = dlapy2(dble(x(j+igap)),aimag(x(j+igap))) +-c +- if (temp1.gt.temp2) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 30 +- end if +- j = j-igap +- go to 20 +- 30 continue +- igap = igap / 2 +- go to 10 +-c +- else if (which .eq. 'SM') then +-c +-c %--------------------------------------------% +-c | Sort X into decreasing order of magnitude. | +-c %--------------------------------------------% +-c +- 40 continue +- if (igap .eq. 0) go to 9000 +-c +- do 60 i = igap, n-1 +- j = i-igap +- 50 continue +-c +- if (j .lt. 0) go to 60 +-c +- temp1 = dlapy2(dble(x(j)),aimag(x(j))) +- temp2 = dlapy2(dble(x(j+igap)),aimag(x(j+igap))) +-c +- if (temp1.lt.temp2) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 60 +- endif +- j = j-igap +- go to 50 +- 60 continue +- igap = igap / 2 +- go to 40 +-c +- else if (which .eq. 'LR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into increasing order of algebraic. | +-c %------------------------------------------------% +-c +- 70 continue +- if (igap .eq. 0) go to 9000 +-c +- do 90 i = igap, n-1 +- j = i-igap +- 80 continue +-c +- if (j.lt.0) go to 90 +-c +- if (dble(x(j)).gt.dble(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 90 +- endif +- j = j-igap +- go to 80 +- 90 continue +- igap = igap / 2 +- go to 70 +-c +- else if (which .eq. 'SR') then +-c +-c %------------------------------------------------% +-c | Sort XREAL into decreasing order of algebraic. | +-c %------------------------------------------------% +-c +- 100 continue +- if (igap .eq. 0) go to 9000 +- do 120 i = igap, n-1 +- j = i-igap +- 110 continue +-c +- if (j.lt.0) go to 120 +-c +- if (dble(x(j)).lt.dble(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 120 +- endif +- j = j-igap +- go to 110 +- 120 continue +- igap = igap / 2 +- go to 100 +-c +- else if (which .eq. 'LI') then +-c +-c %--------------------------------------------% +-c | Sort XIMAG into increasing algebraic order | +-c %--------------------------------------------% +-c +- 130 continue +- if (igap .eq. 0) go to 9000 +- do 150 i = igap, n-1 +- j = i-igap +- 140 continue +-c +- if (j.lt.0) go to 150 +-c +- if (aimag(x(j)).gt.aimag(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 150 +- endif +- j = j-igap +- go to 140 +- 150 continue +- igap = igap / 2 +- go to 130 +-c +- else if (which .eq. 'SI') then +-c +-c %---------------------------------------------% +-c | Sort XIMAG into decreasing algebraic order | +-c %---------------------------------------------% +-c +- 160 continue +- if (igap .eq. 0) go to 9000 +- do 180 i = igap, n-1 +- j = i-igap +- 170 continue +-c +- if (j.lt.0) go to 180 +-c +- if (aimag(x(j)).lt.aimag(x(j+igap))) then +- temp = x(j) +- x(j) = x(j+igap) +- x(j+igap) = temp +-c +- if (apply) then +- temp = y(j) +- y(j) = y(j+igap) +- y(j+igap) = temp +- end if +- else +- go to 180 +- endif +- j = j-igap +- go to 170 +- 180 continue +- igap = igap / 2 +- go to 160 +- end if +-c +- 9000 continue +- return +-c +-c %---------------% +-c | End of zsortc | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zstatn.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zstatn.f +deleted file mode 100644 +index ddc5240f3f..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zstatn.f ++++ /dev/null +@@ -1,51 +0,0 @@ +-c +-c\SCCS Information: @(#) +-c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 +-c +-c %---------------------------------------------% +-c | Initialize statistic and timing information | +-c | for complex nonsymmetric Arnoldi code. | +-c %---------------------------------------------% +- +- subroutine zstatn +-c +-c %--------------------------------% +-c | See stat.doc for documentation | +-c %--------------------------------% +-c +- include 'stat.h' +- +-c %-----------------------% +-c | Executable Statements | +-c %-----------------------% +- +- nopx = 0 +- nbx = 0 +- nrorth = 0 +- nitref = 0 +- nrstrt = 0 +- +- tcaupd = 0.0D+0 +- tcaup2 = 0.0D+0 +- tcaitr = 0.0D+0 +- tceigh = 0.0D+0 +- tcgets = 0.0D+0 +- tcapps = 0.0D+0 +- tcconv = 0.0D+0 +- titref = 0.0D+0 +- tgetv0 = 0.0D+0 +- trvec = 0.0D+0 +- +-c %----------------------------------------------------% +-c | User time including reverse communication overhead | +-c %----------------------------------------------------% +- tmvopx = 0.0D+0 +- tmvbx = 0.0D+0 +- +- return +-c +-c %---------------% +-c | End of zstatn | +-c %---------------% +-c +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zzdotc.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zzdotc.f +deleted file mode 100644 +index a98c34230c..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/SRC/zzdotc.f ++++ /dev/null +@@ -1,36 +0,0 @@ +- double complex function zzdotc(n,zx,incx,zy,incy) +-c +-c forms the dot product of a vector. +-c jack dongarra, 3/11/78. +-c modified 12/3/93, array(1) declarations changed to array(*) +-c +- double complex zx(*),zy(*),ztemp +- integer i,incx,incy,ix,iy,n +- ztemp = (0.0d0,0.0d0) +- zzdotc = (0.0d0,0.0d0) +- if(n.le.0)return +- if(incx.eq.1.and.incy.eq.1)go to 20 +-c +-c code for unequal increments or equal increments +-c 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 +- do 10 i = 1,n +- ztemp = ztemp + conjg(zx(ix))*zy(iy) +- ix = ix + incx +- iy = iy + incy +- 10 continue +- zzdotc = ztemp +- return +-c +-c code for both increments equal to 1 +-c +- 20 do 30 i = 1,n +- ztemp = ztemp + conjg(zx(i))*zy(i) +- 30 continue +- zzdotc = ztemp +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cmout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cmout.f +deleted file mode 100644 +index ff04783099..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cmout.f ++++ /dev/null +@@ -1,250 +0,0 @@ +-* +-* Routine: CMOUT +-* +-* Purpose: Complex matrix output routine. +-* +-* Usage: CALL CMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) +-* +-* Arguments +-* M - Number of rows of A. (Input) +-* N - Number of columns of A. (Input) +-* A - Complex M by N matrix to be printed. (Input) +-* LDA - Leading dimension of A exactly as specified in the +-* dimension statement of the calling program. (Input) +-* IFMT - Format to be used in printing matrix A. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*\SCCS Information: @(#) +-* FILE: cmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE CMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER M, N, IDIGIT, LDA, LOUT +- Complex +- & A( LDA, * ) +- CHARACTER IFMT*( * ) +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, J, NDIGIT, K1, K2, LLL +- CHARACTER*1 ICOL( 3 ) +- CHARACTER*80 LINE +-* ... +-* ... SPECIFICATIONS INTRINSICS +- INTRINSIC MIN +-* +- DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', +- $ 'l' / +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A / 1X, A ) +-* +- IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 40 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) +- DO 30 I = 1, M +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 30 CONTINUE +- 40 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 60 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) +- DO 50 I = 1, M +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 50 CONTINUE +- 60 CONTINUE +-* +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 80 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) +- DO 70 I = 1, M +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 70 CONTINUE +- 80 CONTINUE +-* +- ELSE +- DO 100 K1 = 1, N +- WRITE( LOUT, 9995 ) ICOL, K1 +- DO 90 I = 1, M +- WRITE( LOUT, 9991 )I, A( I, K1 ) +- 90 CONTINUE +- 100 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 120 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) +- DO 110 I = 1, M +- IF ((K1+3).LE.N) THEN +- WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+3-N).EQ.1) THEN +- WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) +- ELSE IF ((K1+3-N).EQ.2) THEN +- WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+3-N).EQ.3) THEN +- WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 110 CONTINUE +- 120 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 140 K1 = 1, N, 3 +- K2 = MIN0( N, K1+ 2) +- WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) +- DO 130 I = 1, M +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.1) THEN +- WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.2) THEN +- WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 130 CONTINUE +- 140 CONTINUE +-* +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 160 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) +- DO 150 I = 1, M +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.1) THEN +- WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.2) THEN +- WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 150 CONTINUE +- 160 CONTINUE +-* +- ELSE +- DO 180 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) +- DO 170 I = 1, M +- IF ((K1+1).LE.N) THEN +- WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 170 CONTINUE +- 180 CONTINUE +- END IF +- END IF +- WRITE( LOUT, 9990 ) +-* +- 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) +- 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) +- 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) +- 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) +-* +-*======================================================== +-* FORMAT FOR 72 COLUMN +-*======================================================== +-* +-* DISPLAY 4 SIGNIFICANT DIGITS +-* +- 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) +- 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGITS +-* +- 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) +- 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGITS +-* +- 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) +- 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGITS +-* +- 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13,')') ) +- 9990 FORMAT( 1X, ' ' ) +-* +-* +-*======================================================== +-* FORMAT FOR 132 COLUMN +-*======================================================== +-* +-* DISPLAY 4 SIGNIFICANT DIGIT +-* +- 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',E10.3,',',E10.3,') ') ) +- 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E10.3,',',E10.3,') ') ) +- 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) +- 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGIT +-* +- 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E12.5,',',E12.5,') ') ) +- 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) +- 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGIT +-* +- 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E14.7,',',E14.7,') ') ) +- 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) +- 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGIT +-* +- 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E20.13,',',E20.13, +- & ') ')) +- 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13, +- & ') ')) +- +-* +-* +-* +-* +- RETURN +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cvout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cvout.f +deleted file mode 100644 +index 1ee9afabf7..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/cvout.f ++++ /dev/null +@@ -1,240 +0,0 @@ +-c----------------------------------------------------------------------- +-c +-c\SCCS Information: @(#) +-c FILE: cvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 +-c +-*----------------------------------------------------------------------- +-* Routine: CVOUT +-* +-* Purpose: Complex vector output routine. +-* +-* Usage: CALL CVOUT (LOUT, N, CX, IDIGIT, IFMT) +-* +-* Arguments +-* N - Length of array CX. (Input) +-* CX - Complex array to be printed. (Input) +-* IFMT - Format to be used in printing array CX. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE CVOUT( LOUT, N, CX, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER N, IDIGIT, LOUT +- Complex +- & CX( * ) +- CHARACTER IFMT*( * ) +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, NDIGIT, K1, K2, LLL +- CHARACTER*80 LINE +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A / 1X, A ) +-* +- IF( N.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 30 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9998 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE +- WRITE( LOUT, 9997 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 30 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 40 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9988 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE +- WRITE( LOUT, 9987 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 40 CONTINUE +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 50 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9978 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE +- WRITE( LOUT, 9977 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 50 CONTINUE +- ELSE +- DO 60 K1 = 1, N +- WRITE( LOUT, 9968 )K1, K1, CX( I ) +- 60 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 70 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- IF ((K1+3).LE.N) THEN +- WRITE( LOUT, 9958 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+3-N) .EQ. 1) THEN +- WRITE( LOUT, 9957 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+3-N) .EQ. 2) THEN +- WRITE( LOUT, 9956 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+3-N) .EQ. 1) THEN +- WRITE( LOUT, 9955 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 70 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 80 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9948 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 1) THEN +- WRITE( LOUT, 9947 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 2) THEN +- WRITE( LOUT, 9946 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 80 CONTINUE +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 90 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9938 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 1) THEN +- WRITE( LOUT, 9937 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 2) THEN +- WRITE( LOUT, 9936 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 90 CONTINUE +- ELSE +- DO 100 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9928 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 1) THEN +- WRITE( LOUT, 9927 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 100 CONTINUE +- END IF +- END IF +- WRITE( LOUT, 9994 ) +- RETURN +-* +-*======================================================================= +-* FORMAT FOR 72 COLUMNS +-*======================================================================= +-* +-* DISPLAY 4 SIGNIFICANT DIGITS +-* +- 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E10.3,',',E10.3,') ') ) +- 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E10.3,',',E10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGITS +-* +- 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E12.5,',',E12.5,') ') ) +- 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E12.5,',',E12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGITS +-* +- 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E14.7,',',E14.7,') ') ) +- 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E14.7,',',E14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGITS +-* +- 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E20.13,',',E20.13,') ') ) +-* +-*========================================================================= +-* FORMAT FOR 132 COLUMNS +-*========================================================================= +-* +-* DISPLAY 4 SIGNIFICANT DIGITS +-* +- 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,4('(',E10.3,',',E10.3,') ') ) +- 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,3('(',E10.3,',',E10.3,') ') ) +- 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E10.3,',',E10.3,') ') ) +- 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E10.3,',',E10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGITS +-* +- 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,3('(',E12.5,',',E12.5,') ') ) +- 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E12.5,',',E12.5,') ') ) +- 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E12.5,',',E12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGITS +-* +- 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,3('(',E14.7,',',E14.7,') ') ) +- 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E14.7,',',E14.7,') ') ) +- 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E14.7,',',E14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGITS +-* +- 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',E20.13,',',E20.13,') ') ) +- 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',E20.13,',',E20.13,') ') ) +-* +-* +-* +- 9994 FORMAT( 1X, ' ' ) +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dmout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dmout.f +deleted file mode 100644 +index 72edc042fa..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dmout.f ++++ /dev/null +@@ -1,167 +0,0 @@ +-*----------------------------------------------------------------------- +-* Routine: DMOUT +-* +-* Purpose: Real matrix output routine. +-* +-* Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) +-* +-* Arguments +-* M - Number of rows of A. (Input) +-* N - Number of columns of A. (Input) +-* A - Real M by N matrix to be printed. (Input) +-* LDA - Leading dimension of A exactly as specified in the +-* dimension statement of the calling program. (Input) +-* IFMT - Format to be used in printing matrix A. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +-* .. Scalar Arguments .. +- CHARACTER*( * ) IFMT +- INTEGER IDIGIT, LDA, LOUT, M, N +-* .. +-* .. Array Arguments .. +- DOUBLE PRECISION A( LDA, * ) +-* .. +-* .. Local Scalars .. +- CHARACTER*80 LINE +- INTEGER I, J, K1, K2, LLL, NDIGIT +-* .. +-* .. Local Arrays .. +- CHARACTER ICOL( 3 ) +-* .. +-* .. Intrinsic Functions .. +- INTRINSIC LEN, MIN, MIN0 +-* .. +-* .. Data statements .. +- DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', +- $ 'l' / +-* .. +-* .. Executable Statements .. +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A, / 1X, A ) +-* +- IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 40 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) +- DO 30 I = 1, M +- WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) +- 30 CONTINUE +- 40 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 60 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) +- DO 50 I = 1, M +- WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) +- 50 CONTINUE +- 60 CONTINUE +-* +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 80 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) +- DO 70 I = 1, M +- WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) +- 70 CONTINUE +- 80 CONTINUE +-* +- ELSE +- DO 100 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) +- DO 90 I = 1, M +- WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) +- 90 CONTINUE +- 100 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 120 K1 = 1, N, 10 +- K2 = MIN0( N, K1+9 ) +- WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) +- DO 110 I = 1, M +- WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) +- 110 CONTINUE +- 120 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 140 K1 = 1, N, 8 +- K2 = MIN0( N, K1+7 ) +- WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) +- DO 130 I = 1, M +- WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) +- 130 CONTINUE +- 140 CONTINUE +-* +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 160 K1 = 1, N, 6 +- K2 = MIN0( N, K1+5 ) +- WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) +- DO 150 I = 1, M +- WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) +- 150 CONTINUE +- 160 CONTINUE +-* +- ELSE +- DO 180 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) +- DO 170 I = 1, M +- WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) +- 170 CONTINUE +- 180 CONTINUE +- END IF +- END IF +- WRITE( LOUT, FMT = 9990 ) +-* +- 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) +- 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) +- 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) +- 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) +- 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 ) +- 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 ) +- 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 ) +- 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 ) +- 9990 FORMAT( 1X, ' ' ) +-* +- RETURN +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dvout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dvout.f +deleted file mode 100644 +index 4138e52c6f..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/dvout.f ++++ /dev/null +@@ -1,122 +0,0 @@ +-*----------------------------------------------------------------------- +-* Routine: DVOUT +-* +-* Purpose: Real vector output routine. +-* +-* Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT) +-* +-* Arguments +-* N - Length of array SX. (Input) +-* SX - Real array to be printed. (Input) +-* IFMT - Format to be used in printing array SX. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +-* .. Scalar Arguments .. +- CHARACTER*( * ) IFMT +- INTEGER IDIGIT, LOUT, N +-* .. +-* .. Array Arguments .. +- DOUBLE PRECISION SX( * ) +-* .. +-* .. Local Scalars .. +- CHARACTER*80 LINE +- INTEGER I, K1, K2, LLL, NDIGIT +-* .. +-* .. Intrinsic Functions .. +- INTRINSIC LEN, MIN, MIN0 +-* .. +-* .. Executable Statements .. +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A, / 1X, A ) +-* +- IF( N.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 30 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) +- 30 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 40 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) +- 40 CONTINUE +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 50 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) +- 50 CONTINUE +- ELSE +- DO 60 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) +- 60 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 70 K1 = 1, N, 10 +- K2 = MIN0( N, K1+9 ) +- WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) +- 70 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 80 K1 = 1, N, 8 +- K2 = MIN0( N, K1+7 ) +- WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) +- 80 CONTINUE +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 90 K1 = 1, N, 6 +- K2 = MIN0( N, K1+5 ) +- WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) +- 90 CONTINUE +- ELSE +- DO 100 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) +- 100 CONTINUE +- END IF +- END IF +- WRITE( LOUT, FMT = 9994 ) +- RETURN +- 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 ) +- 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 ) +- 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 ) +- 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 ) +- 9994 FORMAT( 1X, ' ' ) +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icnteq.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icnteq.f +deleted file mode 100644 +index dc345f9bad..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icnteq.f ++++ /dev/null +@@ -1,18 +0,0 @@ +-c +-c----------------------------------------------------------------------- +-c +-c Count the number of elements equal to a specified integer value. +-c +- integer function icnteq (n, array, value) +-c +- integer n, value +- integer array(*) +-c +- k = 0 +- do 10 i = 1, n +- if (array(i) .eq. value) k = k + 1 +- 10 continue +- icnteq = k +-c +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icopy.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icopy.f +deleted file mode 100644 +index f9e8c11003..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/icopy.f ++++ /dev/null +@@ -1,77 +0,0 @@ +-*-------------------------------------------------------------------- +-*\Documentation +-* +-*\Name: ICOPY +-* +-*\Description: +-* ICOPY copies an integer vector lx to an integer vector ly. +-* +-*\Usage: +-* call icopy ( n, lx, inc, ly, incy ) +-* +-*\Arguments: +-* n integer (input) +-* On entry, n is the number of elements of lx to be +-c copied to ly. +-* +-* lx integer array (input) +-* On entry, lx is the integer vector to be copied. +-* +-* incx integer (input) +-* On entry, incx is the increment between elements of lx. +-* +-* ly integer array (input) +-* On exit, ly is the integer vector that contains the +-* copy of lx. +-* +-* incy integer (input) +-* On entry, incy is the increment between elements of ly. +-* +-*\Enddoc +-* +-*-------------------------------------------------------------------- +-* +- subroutine icopy( n, lx, incx, ly, incy ) +-* +-* ---------------------------- +-* Specifications for arguments +-* ---------------------------- +- integer incx, incy, n +- integer lx( 1 ), ly( 1 ) +-* +-* ---------------------------------- +-* Specifications for local variables +-* ---------------------------------- +- integer i, ix, iy +-* +-* -------------------------- +-* First executable statement +-* -------------------------- +- if( n.le.0 ) +- $ return +- if( incx.eq.1 .and. incy.eq.1 ) +- $ go to 20 +-c +-c.....code for unequal increments or equal increments +-c not equal to 1 +- ix = 1 +- iy = 1 +- if( incx.lt.0 ) +- $ ix = ( -n+1 )*incx + 1 +- if( incy.lt.0 ) +- $ iy = ( -n+1 )*incy + 1 +- do 10 i = 1, n +- ly( iy ) = lx( ix ) +- ix = ix + incx +- iy = iy + incy +- 10 continue +- return +-c +-c.....code for both increments equal to 1 +-c +- 20 continue +- do 30 i = 1, n +- ly( i ) = lx( i ) +- 30 continue +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iset.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iset.f +deleted file mode 100644 +index cb690bc3e9..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iset.f ++++ /dev/null +@@ -1,16 +0,0 @@ +-c +-c----------------------------------------------------------------------- +-c +-c Only work with increment equal to 1 right now. +-c +- subroutine iset (n, value, array, inc) +-c +- integer n, value, inc +- integer array(*) +-c +- do 10 i = 1, n +- array(i) = value +- 10 continue +-c +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iswap.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iswap.f +deleted file mode 100644 +index 088798d007..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/iswap.f ++++ /dev/null +@@ -1,55 +0,0 @@ +- subroutine iswap (n,sx,incx,sy,incy) +-c +-c interchanges two vectors. +-c uses unrolled loops for increments equal to 1. +-c jack dongarra, linpack, 3/11/78. +-c +- integer sx(1),sy(1),stemp +- integer i,incx,incy,ix,iy,m,mp1,n +-c +- if(n.le.0)return +- if(incx.eq.1.and.incy.eq.1)go to 20 +-c +-c code for unequal increments or equal increments not equal +-c 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 +- do 10 i = 1,n +- stemp = sx(ix) +- sx(ix) = sy(iy) +- sy(iy) = stemp +- ix = ix + incx +- iy = iy + incy +- 10 continue +- return +-c +-c code for both increments equal to 1 +-c +-c +-c clean-up loop +-c +- 20 m = mod(n,3) +- if( m .eq. 0 ) go to 40 +- do 30 i = 1,m +- stemp = sx(i) +- sx(i) = sy(i) +- sy(i) = stemp +- 30 continue +- if( n .lt. 3 ) return +- 40 mp1 = m + 1 +- do 50 i = mp1,n,3 +- stemp = sx(i) +- sx(i) = sy(i) +- sy(i) = stemp +- stemp = sx(i + 1) +- sx(i + 1) = sy(i + 1) +- sy(i + 1) = stemp +- stemp = sx(i + 2) +- sx(i + 2) = sy(i + 2) +- sy(i + 2) = stemp +- 50 continue +- return +- end +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/ivout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/ivout.f +deleted file mode 100644 +index e97118a86b..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/ivout.f ++++ /dev/null +@@ -1,120 +0,0 @@ +-C----------------------------------------------------------------------- +-C Routine: IVOUT +-C +-C Purpose: Integer vector output routine. +-C +-C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT) +-C +-C Arguments +-C N - Length of array IX. (Input) +-C IX - Integer array to be printed. (Input) +-C IFMT - Format to be used in printing array IX. (Input) +-C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input) +-C If IDIGIT .LT. 0, printing is done with 72 columns. +-C If IDIGIT .GT. 0, printing is done with 132 columns. +-C +-C----------------------------------------------------------------------- +-C +- SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT) +-C ... +-C ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER IX(*), N, IDIGIT, LOUT +- CHARACTER IFMT*(*) +-C ... +-C ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, NDIGIT, K1, K2, LLL +- CHARACTER*80 LINE +-* ... +-* ... SPECIFICATIONS INTRINSICS +- INTRINSIC MIN +-* +-C +- LLL = MIN ( LEN ( IFMT ), 80 ) +- DO 1 I = 1, LLL +- LINE(I:I) = '-' +- 1 CONTINUE +-C +- DO 2 I = LLL+1, 80 +- LINE(I:I) = ' ' +- 2 CONTINUE +-C +- WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL) +- 2000 FORMAT ( /1X, A /1X, A ) +-C +- IF (N .LE. 0) RETURN +- NDIGIT = IDIGIT +- IF (IDIGIT .EQ. 0) NDIGIT = 4 +-C +-C======================================================================= +-C CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-C======================================================================= +-C +- IF (IDIGIT .LT. 0) THEN +-C +- NDIGIT = -IDIGIT +- IF (NDIGIT .LE. 4) THEN +- DO 10 K1 = 1, N, 10 +- K2 = MIN0(N,K1+9) +- WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) +- 10 CONTINUE +-C +- ELSE IF (NDIGIT .LE. 6) THEN +- DO 30 K1 = 1, N, 7 +- K2 = MIN0(N,K1+6) +- WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) +- 30 CONTINUE +-C +- ELSE IF (NDIGIT .LE. 10) THEN +- DO 50 K1 = 1, N, 5 +- K2 = MIN0(N,K1+4) +- WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) +- 50 CONTINUE +-C +- ELSE +- DO 70 K1 = 1, N, 3 +- K2 = MIN0(N,K1+2) +- WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) +- 70 CONTINUE +- END IF +-C +-C======================================================================= +-C CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-C======================================================================= +-C +- ELSE +-C +- IF (NDIGIT .LE. 4) THEN +- DO 90 K1 = 1, N, 20 +- K2 = MIN0(N,K1+19) +- WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) +- 90 CONTINUE +-C +- ELSE IF (NDIGIT .LE. 6) THEN +- DO 110 K1 = 1, N, 15 +- K2 = MIN0(N,K1+14) +- WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) +- 110 CONTINUE +-C +- ELSE IF (NDIGIT .LE. 10) THEN +- DO 130 K1 = 1, N, 10 +- K2 = MIN0(N,K1+9) +- WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) +- 130 CONTINUE +-C +- ELSE +- DO 150 K1 = 1, N, 7 +- K2 = MIN0(N,K1+6) +- WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) +- 150 CONTINUE +- END IF +- END IF +- WRITE (LOUT,1004) +-C +- 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5)) +- 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7)) +- 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11)) +- 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15)) +- 1004 FORMAT(1X,' ') +-C +- RETURN +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/second_NONE.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/second_NONE.f +deleted file mode 100644 +index 01fcc9dcf8..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/second_NONE.f ++++ /dev/null +@@ -1,36 +0,0 @@ +- SUBROUTINE ARSCND( T ) +-* +- REAL T +-* +-* -- LAPACK auxiliary routine (preliminary version) -- +-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +-* Courant Institute, Argonne National Lab, and Rice University +-* July 26, 1991 +-* +-* Purpose +-* ======= +-* +-* SECOND returns the user time for a process in arscnds. +-* This version gets the time from the system function ETIME. +-* +-* .. Local Scalars .. +- REAL T1 +-* .. +-* .. Local Arrays .. +- REAL TARRAY( 2 ) +-* .. +-* .. External Functions .. +- REAL ETIME +- EXTERNAL ETIME +-* .. +-* .. Executable Statements .. +-* +- +-c T1 = ETIME( TARRAY ) +-c T = TARRAY( 1 ) +- T = 0 +- RETURN +-* +-* End of ARSCND +-* +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/smout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/smout.f +deleted file mode 100644 +index 8d90bf2099..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/smout.f ++++ /dev/null +@@ -1,157 +0,0 @@ +-*----------------------------------------------------------------------- +-* Routine: SMOUT +-* +-* Purpose: Real matrix output routine. +-* +-* Usage: CALL SMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) +-* +-* Arguments +-* M - Number of rows of A. (Input) +-* N - Number of columns of A. (Input) +-* A - Real M by N matrix to be printed. (Input) +-* LDA - Leading dimension of A exactly as specified in the +-* dimension statement of the calling program. (Input) +-* IFMT - Format to be used in printing matrix A. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE SMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER M, N, IDIGIT, LDA, LOUT +- REAL A( LDA, * ) +- CHARACTER IFMT*( * ) +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, J, NDIGIT, K1, K2, LLL +- CHARACTER*1 ICOL( 3 ) +- CHARACTER*80 LINE +-* ... +-* ... SPECIFICATIONS INTRINSICS +- INTRINSIC MIN +-* +- DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', +- $ 'l' / +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A / 1X, A ) +-* +- IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 40 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) +- DO 30 I = 1, M +- WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) +- 30 CONTINUE +- 40 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 60 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) +- DO 50 I = 1, M +- WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) +- 50 CONTINUE +- 60 CONTINUE +-* +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 80 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) +- DO 70 I = 1, M +- WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) +- 70 CONTINUE +- 80 CONTINUE +-* +- ELSE +- DO 100 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) +- DO 90 I = 1, M +- WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) +- 90 CONTINUE +- 100 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 120 K1 = 1, N, 10 +- K2 = MIN0( N, K1+9 ) +- WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) +- DO 110 I = 1, M +- WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) +- 110 CONTINUE +- 120 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 140 K1 = 1, N, 8 +- K2 = MIN0( N, K1+7 ) +- WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) +- DO 130 I = 1, M +- WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) +- 130 CONTINUE +- 140 CONTINUE +-* +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 160 K1 = 1, N, 6 +- K2 = MIN0( N, K1+5 ) +- WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) +- DO 150 I = 1, M +- WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) +- 150 CONTINUE +- 160 CONTINUE +-* +- ELSE +- DO 180 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) +- DO 170 I = 1, M +- WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) +- 170 CONTINUE +- 180 CONTINUE +- END IF +- END IF +- WRITE( LOUT, 9990 ) +-* +- 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) +- 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) +- 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) +- 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) +- 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P10E12.3 ) +- 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P8E14.5 ) +- 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P6E18.9 ) +- 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P5E22.13 ) +- 9990 FORMAT( 1X, ' ' ) +-* +- RETURN +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/svout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/svout.f +deleted file mode 100644 +index 4363b924b2..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/svout.f ++++ /dev/null +@@ -1,112 +0,0 @@ +-*----------------------------------------------------------------------- +-* Routine: SVOUT +-* +-* Purpose: Real vector output routine. +-* +-* Usage: CALL SVOUT (LOUT, N, SX, IDIGIT, IFMT) +-* +-* Arguments +-* N - Length of array SX. (Input) +-* SX - Real array to be printed. (Input) +-* IFMT - Format to be used in printing array SX. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE SVOUT( LOUT, N, SX, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER N, IDIGIT, LOUT +- REAL SX( * ) +- CHARACTER IFMT*( * ) +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, NDIGIT, K1, K2, LLL +- CHARACTER*80 LINE +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A / 1X, A ) +-* +- IF( N.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 30 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) +- 30 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 40 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) +- 40 CONTINUE +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 50 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) +- 50 CONTINUE +- ELSE +- DO 60 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) +- 60 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 70 K1 = 1, N, 10 +- K2 = MIN0( N, K1+9 ) +- WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) +- 70 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 80 K1 = 1, N, 8 +- K2 = MIN0( N, K1+7 ) +- WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) +- 80 CONTINUE +- ELSE IF( NDIGIT.LE.10 ) THEN +- DO 90 K1 = 1, N, 6 +- K2 = MIN0( N, K1+5 ) +- WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) +- 90 CONTINUE +- ELSE +- DO 100 K1 = 1, N, 5 +- K2 = MIN0( N, K1+4 ) +- WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) +- 100 CONTINUE +- END IF +- END IF +- WRITE( LOUT, 9994 ) +- RETURN +- 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P10E12.3 ) +- 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P8E14.5 ) +- 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P6E18.9 ) +- 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P5E24.13 ) +- 9994 FORMAT( 1X, ' ' ) +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zmout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zmout.f +deleted file mode 100644 +index c39f6defee..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zmout.f ++++ /dev/null +@@ -1,250 +0,0 @@ +-* +-* Routine: ZMOUT +-* +-* Purpose: Complex*16 matrix output routine. +-* +-* Usage: CALL ZMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) +-* +-* Arguments +-* M - Number of rows of A. (Input) +-* N - Number of columns of A. (Input) +-* A - Complex*16 M by N matrix to be printed. (Input) +-* LDA - Leading dimension of A exactly as specified in the +-* dimension statement of the calling program. (Input) +-* IFMT - Format to be used in printing matrix A. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*\SCCS Information: @(#) +-* FILE: zmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE ZMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER M, N, IDIGIT, LDA, LOUT +- Complex*16 +- & A( LDA, * ) +- CHARACTER IFMT*( * ) +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, J, NDIGIT, K1, K2, LLL +- CHARACTER*1 ICOL( 3 ) +- CHARACTER*80 LINE +-* ... +-* ... SPECIFICATIONS INTRINSICS +- INTRINSIC MIN +-* +- DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', +- $ 'l' / +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A / 1X, A ) +-* +- IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 40 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) +- DO 30 I = 1, M +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 30 CONTINUE +- 40 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 60 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) +- DO 50 I = 1, M +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 50 CONTINUE +- 60 CONTINUE +-* +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 80 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) +- DO 70 I = 1, M +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 70 CONTINUE +- 80 CONTINUE +-* +- ELSE +- DO 100 K1 = 1, N +- WRITE( LOUT, 9995 ) ICOL, K1 +- DO 90 I = 1, M +- WRITE( LOUT, 9991 )I, A( I, K1 ) +- 90 CONTINUE +- 100 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 120 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) +- DO 110 I = 1, M +- IF ((K1+3).LE.N) THEN +- WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+3-N).EQ.1) THEN +- WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) +- ELSE IF ((K1+3-N).EQ.2) THEN +- WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+3-N).EQ.3) THEN +- WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 110 CONTINUE +- 120 CONTINUE +-* +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 140 K1 = 1, N, 3 +- K2 = MIN0( N, K1+ 2) +- WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) +- DO 130 I = 1, M +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.1) THEN +- WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.2) THEN +- WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 130 CONTINUE +- 140 CONTINUE +-* +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 160 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) +- DO 150 I = 1, M +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.1) THEN +- WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) +- ELSE IF ((K1+2-N).EQ.2) THEN +- WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 150 CONTINUE +- 160 CONTINUE +-* +- ELSE +- DO 180 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) +- DO 170 I = 1, M +- IF ((K1+1).LE.N) THEN +- WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) +- ELSE +- WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) +- END IF +- 170 CONTINUE +- 180 CONTINUE +- END IF +- END IF +- WRITE( LOUT, 9990 ) +-* +- 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) +- 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) +- 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) +- 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) +-* +-*======================================================== +-* FORMAT FOR 72 COLUMN +-*======================================================== +-* +-* DISPLAY 4 SIGNIFICANT DIGITS +-* +- 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) +- 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGITS +-* +- 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) +- 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGITS +-* +- 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) +- 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGITS +-* +- 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13,')') ) +- 9990 FORMAT( 1X, ' ' ) +-* +-* +-*======================================================== +-* FORMAT FOR 132 COLUMN +-*======================================================== +-* +-* DISPLAY 4 SIGNIFICANT DIGIT +-* +- 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',D10.3,',',D10.3,') ') ) +- 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D10.3,',',D10.3,') ') ) +- 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) +- 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGIT +-* +- 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D12.5,',',D12.5,') ') ) +- 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) +- 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGIT +-* +- 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D14.7,',',D14.7,') ') ) +- 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) +- 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGIT +-* +- 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D20.13,',',D20.13, +- & ') ')) +- 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13, +- & ') ')) +- +-* +-* +-* +-* +- RETURN +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zvout.f b/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zvout.f +deleted file mode 100644 +index 8c42eb8908..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/ARPACK/UTIL/zvout.f ++++ /dev/null +@@ -1,240 +0,0 @@ +-c----------------------------------------------------------------------- +-c +-c\SCCS Information: @(#) +-c FILE: zvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 +-c +-*----------------------------------------------------------------------- +-* Routine: ZVOUT +-* +-* Purpose: Complex*16 vector output routine. +-* +-* Usage: CALL ZVOUT (LOUT, N, CX, IDIGIT, IFMT) +-* +-* Arguments +-* N - Length of array CX. (Input) +-* CX - Complex*16 array to be printed. (Input) +-* IFMT - Format to be used in printing array CX. (Input) +-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) +-* If IDIGIT .LT. 0, printing is done with 72 columns. +-* If IDIGIT .GT. 0, printing is done with 132 columns. +-* +-*----------------------------------------------------------------------- +-* +- SUBROUTINE ZVOUT( LOUT, N, CX, IDIGIT, IFMT ) +-* ... +-* ... SPECIFICATIONS FOR ARGUMENTS +- INTEGER N, IDIGIT, LOUT +- Complex*16 +- & CX( * ) +- CHARACTER IFMT*( * ) +-* ... +-* ... SPECIFICATIONS FOR LOCAL VARIABLES +- INTEGER I, NDIGIT, K1, K2, LLL +- CHARACTER*80 LINE +-* ... +-* ... FIRST EXECUTABLE STATEMENT +-* +-* +- LLL = MIN( LEN( IFMT ), 80 ) +- DO 10 I = 1, LLL +- LINE( I: I ) = '-' +- 10 CONTINUE +-* +- DO 20 I = LLL + 1, 80 +- LINE( I: I ) = ' ' +- 20 CONTINUE +-* +- WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) +- 9999 FORMAT( / 1X, A / 1X, A ) +-* +- IF( N.LE.0 ) +- $ RETURN +- NDIGIT = IDIGIT +- IF( IDIGIT.EQ.0 ) +- $ NDIGIT = 4 +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 72 COLUMNS FORMAT +-*======================================================================= +-* +- IF( IDIGIT.LT.0 ) THEN +- NDIGIT = -IDIGIT +- IF( NDIGIT.LE.4 ) THEN +- DO 30 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9998 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE +- WRITE( LOUT, 9997 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 30 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 40 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9988 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE +- WRITE( LOUT, 9987 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 40 CONTINUE +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 50 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF (K1.NE.N) THEN +- WRITE( LOUT, 9978 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE +- WRITE( LOUT, 9977 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 50 CONTINUE +- ELSE +- DO 60 K1 = 1, N +- WRITE( LOUT, 9968 )K1, K1, CX( I ) +- 60 CONTINUE +- END IF +-* +-*======================================================================= +-* CODE FOR OUTPUT USING 132 COLUMNS FORMAT +-*======================================================================= +-* +- ELSE +- IF( NDIGIT.LE.4 ) THEN +- DO 70 K1 = 1, N, 4 +- K2 = MIN0( N, K1+3 ) +- IF ((K1+3).LE.N) THEN +- WRITE( LOUT, 9958 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+3-N) .EQ. 1) THEN +- WRITE( LOUT, 9957 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+3-N) .EQ. 2) THEN +- WRITE( LOUT, 9956 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+3-N) .EQ. 1) THEN +- WRITE( LOUT, 9955 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 70 CONTINUE +- ELSE IF( NDIGIT.LE.6 ) THEN +- DO 80 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9948 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 1) THEN +- WRITE( LOUT, 9947 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 2) THEN +- WRITE( LOUT, 9946 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 80 CONTINUE +- ELSE IF( NDIGIT.LE.8 ) THEN +- DO 90 K1 = 1, N, 3 +- K2 = MIN0( N, K1+2 ) +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9938 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 1) THEN +- WRITE( LOUT, 9937 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 2) THEN +- WRITE( LOUT, 9936 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 90 CONTINUE +- ELSE +- DO 100 K1 = 1, N, 2 +- K2 = MIN0( N, K1+1 ) +- IF ((K1+2).LE.N) THEN +- WRITE( LOUT, 9928 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- ELSE IF ((K1+2-N) .EQ. 1) THEN +- WRITE( LOUT, 9927 )K1, K2, ( CX( I ), +- $ I = K1, K2 ) +- END IF +- 100 CONTINUE +- END IF +- END IF +- WRITE( LOUT, 9994 ) +- RETURN +-* +-*======================================================================= +-* FORMAT FOR 72 COLUMNS +-*======================================================================= +-* +-* DISPLAY 4 SIGNIFICANT DIGITS +-* +- 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D10.3,',',D10.3,') ') ) +- 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D10.3,',',D10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGITS +-* +- 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D12.5,',',D12.5,') ') ) +- 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D12.5,',',D12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGITS +-* +- 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D14.7,',',D14.7,') ') ) +- 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D14.7,',',D14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGITS +-* +- 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D20.13,',',D20.13,') ') ) +-* +-*========================================================================= +-* FORMAT FOR 132 COLUMNS +-*========================================================================= +-* +-* DISPLAY 4 SIGNIFICANT DIGITS +-* +- 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,4('(',D10.3,',',D10.3,') ') ) +- 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,3('(',D10.3,',',D10.3,') ') ) +- 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D10.3,',',D10.3,') ') ) +- 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D10.3,',',D10.3,') ') ) +-* +-* DISPLAY 6 SIGNIFICANT DIGITS +-* +- 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,3('(',D12.5,',',D12.5,') ') ) +- 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D12.5,',',D12.5,') ') ) +- 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D12.5,',',D12.5,') ') ) +-* +-* DISPLAY 8 SIGNIFICANT DIGITS +-* +- 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,3('(',D14.7,',',D14.7,') ') ) +- 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D14.7,',',D14.7,') ') ) +- 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D14.7,',',D14.7,') ') ) +-* +-* DISPLAY 13 SIGNIFICANT DIGITS +-* +- 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,2('(',D20.13,',',D20.13,') ') ) +- 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, +- $ 1P,1('(',D20.13,',',D20.13,') ') ) +-* +-* +-* +- 9994 FORMAT( 1X, ' ' ) +- END +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack.h +new file mode 100644 +index 0000000000..89c07e6557 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack.h +@@ -0,0 +1,266 @@ ++/* ++ ++ This is a C adaptation and rewrite of the well-known Fortran77 ARPACK large-scale ++ eigenvalue problem solver, which is widely used in scientific computing, authored ++ by Richard Lehoucq, Kristi Maschhoff, Danny Sorensen, and Chao Yang. ++ ++ The source is based on the original Fortran77 and a few of the patches collected ++ over the years. The patched Fortran code can be found at arpack-ng repository ++ on GitHub, at the time of writing version 3.9.1: ++ ++ https://github.com/opencollab/arpack-ng/ ++ ++ While the translation is done mostly, in a straightforward fashion, however, ++ still there are significant changes, namely, XYapps.f and Xstqrb.f are rewritten ++ to avoid the goto-based flow. This version also includes API breaking changes to ++ make it more flexible to be included in other projects. ++ ++ ARPACK uses the so-called reverse-communication style that typically exits ++ the program with its in/out arguments to signal, in what stage the algorithm ++ is and what it needs. Then user modifies the arguments and calls again with ++ the necessary information. Thus the state of the whole program is sent back ++ and forth through in-place modified arguments. On top of this, ARPACK also ++ uses lots of variables through the Fortran's dreadful use of SAVE attribute ++ (similar to that of C language STATIC keyword inside a function body) that ++ persists the variable values across consecutive calls. Instead we move all ++ those variables into the reverse communication layer by a C-struct bridge and ++ for array arguments pointers that are provided by the user to make modifications ++ in-place without any alloc/free. This struct bridge also allows for reentrancy ++ and avoids the issues that come with thread safety. ++ ++ Compared to the original Fortran code, random number generation is now delegated ++ to the user side to allow for seed control, custom generators and replicable runs. ++ Hence, the ido_RANDOM and ido_RANDOM_OPX codes are used to signal that the user ++ input is needed. In turn the ido mode -1 is removed. ++ ++ ++ ============================================================================== ++ ++ Author: Ilhan Polat ++ Copyright (C) 2025 SciPy developers ++ ++ Redistribution and use in source and binary forms, with or without ++ modification, are permitted provided that the following conditions are met: ++ a. Redistributions of source code must retain the above copyright notice, ++ this list of conditions and the following disclaimer. ++ b. Redistributions in binary form must reproduce the above copyright ++ notice, this list of conditions and the following disclaimer in the ++ documentation and/or other materials provided with the distribution. ++ c. Names of the SciPy Developers may not be used to endorse or promote ++ products derived from this software without specific prior written ++ permission. ++ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ++ AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ++ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ++ ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS ++ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, ++ OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ++ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ++ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ++ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ++ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF ++ THE POSSIBILITY OF SUCH DAMAGE. ++ ++ ++ Original Fortran77 ARPACK code license; ++ ++------------- ++ ++ The ARPACK license is the BSD 3-clause license ("New BSD License") ++ ++ BSD Software License ++ ++ Pertains to ARPACK and P_ARPACK ++ ++ Copyright (c) 1996-2008 Rice University. ++ Developed by D.C. Sorensen, R.B. Lehoucq, C. Yang, and K. Maschhoff. ++ All rights reserved. ++ ++ Redistribution and use in source and binary forms, with or without ++ modification, are permitted provided that the following conditions are ++ met: ++ ++ - Redistributions of source code must retain the above copyright ++ notice, this list of conditions and the following disclaimer. ++ ++ - Redistributions in binary form must reproduce the above copyright ++ notice, this list of conditions and the following disclaimer listed ++ in this license in the documentation and/or other materials ++ provided with the distribution. ++ ++ - Neither the name of the copyright holders nor the names of its ++ contributors may be used to endorse or promote products derived from ++ this software without specific prior written permission. ++ ++ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ++ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ++ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ++ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ++ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ++ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ++ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ++ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ++ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ++ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ++ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++ ++*/ ++ ++ ++ ++#ifndef _ARPACK_H ++#define _ARPACK_H ++ ++#include ++#include ++ ++#if defined(_MSC_VER) ++ // MSVC definitions ++ typedef _Dcomplex ARPACK_CPLX_TYPE; ++ typedef _Fcomplex ARPACK_CPLXF_TYPE; ++ ++#else ++ // C99 compliant compilers ++ typedef double complex ARPACK_CPLX_TYPE; ++ typedef float complex ARPACK_CPLXF_TYPE; ++ ++#endif ++ ++ ++enum ARPACK_which { ++ which_LM = 0, // want the NEV eigenvalues of largest magnitude. ++ which_SM = 1, // want the NEV eigenvalues of smallest magnitude. ++ which_LR = 2, // want the NEV eigenvalues of largest real part. ++ which_SR = 3, // want the NEV eigenvalues of smallest real part. ++ which_LI = 4, // want the NEV eigenvalues of largest imaginary part. ++ which_SI = 5, // want the NEV eigenvalues of smallest imaginary part. ++ which_LA = 6, // compute the NEV largest (algebraic) eigenvalues. (sym) ++ which_SA = 7, // compute the NEV smallest (algebraic) eigenvalues. (sym) ++ which_BE = 8 // compute NEV eigenvalues, half from each end of the spectrum. (sym) ++}; ++ ++enum ARPACK_ido { ++ ido_FIRST = 0, // First call ++ ido_OPX = 1, // OP*x needed ++ ido_BX = 2, // B*x needed ++ ido_USER_SHIFT = 3, // User shifts are needed ++ ido_RANDOM = 4, // A random vector is needed to be written in resid ++ ido_RANDOM_OPX = 5, // Force random vector to be in the range of OP ++ ido_DONE = 99 // Done ++}; ++ ++/** ++ * With the following structs, we collect all "SAVE"d Fortran variables to track ++ * the problem and avoid reentry issues. It is not the cleanest and is laborious ++ * but otherwise reentrancy is compromised. There are additional variables in the ++ * original Fortran code that are also "SAVE"d however upon inspection, they ++ * are assigned and then used in the same call and thus used without saving. ++**/ ++ ++struct ARPACK_arnoldi_update_vars_s { ++ float tol; // problem parameter input parameter ++ float getv0_rnorm0; // getv0 internal compute internal ++ float aitr_betaj; // naitr internal compute internal ++ float aitr_rnorm1; // naitr internal compute internal ++ float aitr_wnorm; // naitr internal compute internal ++ float aup2_rnorm; // naup2 internal compute internal ++ enum ARPACK_which which; // naupd flow control input ++ enum ARPACK_ido ido; // naupd flow control input/output ++ int info; // problem outcome, input/output ++ int bmat; // problem parameter, boolean input ++ int mode; // problem parameter, input ++ int n; // problem parameter, input ++ int ncv; // problem parameter, input ++ int nev; // problem parameter, input ++ int shift; // problem parameter, boolean input ++ int maxiter; // problem parameter, input ++ int nconv; // problem outcome, output ++ int iter; // problem intermediate, internal ++ int np; // problem intermediate, internal ++ int getv0_first; // getv0 flow control internal ++ int getv0_iter; // getv0 flow control internal ++ int getv0_itry; // getv0 flow control internal ++ int getv0_orth; // getv0 flow control internal ++ int aitr_iter; // naitr flow control internal ++ int aitr_j; // naitr flow control internal ++ int aitr_orth1; // naitr flow control internal ++ int aitr_orth2; // naitr flow control internal ++ int aitr_restart; // naitr flow control internal ++ int aitr_step3; // naitr flow control internal ++ int aitr_step4; // naitr flow control internal ++ int aitr_ierr; // naitr flow control internal ++ int aup2_initv; // naupd2 flow control internal ++ int aup2_iter; // naupd2 flow control internal ++ int aup2_getv0; // naupd2 flow control internal ++ int aup2_cnorm; // naupd2 flow control internal ++ int aup2_kplusp; // naupd2 flow control internal ++ int aup2_nev0; // naupd2 internal compute internal ++ int aup2_np0; // naupd2 internal compute internal ++ int aup2_numcnv; // naupd2 internal compute internal ++ int aup2_update; // naupd2 flow control internal ++ int aup2_ushift; // naupd2 flow control internal ++}; ++ ++ ++struct ARPACK_arnoldi_update_vars_d { ++ double tol; // problem parameter input parameter ++ double getv0_rnorm0; // getv0 internal compute internal ++ double aitr_betaj; // naitr internal compute internal ++ double aitr_rnorm1; // naitr internal compute internal ++ double aitr_wnorm; // naitr internal compute internal ++ double aup2_rnorm; // naup2 internal compute internal ++ enum ARPACK_which which; // naupd flow control input ++ enum ARPACK_ido ido; // naupd flow control input/output ++ int info; // problem outcome, input/output ++ int bmat; // problem parameter, boolean input ++ int mode; // problem parameter, input ++ int n; // problem parameter, input ++ int ncv; // problem parameter, input ++ int nev; // problem parameter, input ++ int shift; // problem parameter, boolean input ++ int maxiter; // problem parameter, input ++ int nconv; // problem outcome, output ++ int iter; // problem intermediate, internal ++ int np; // problem intermediate, internal ++ int getv0_first; // getv0 flow control internal ++ int getv0_iter; // getv0 flow control internal ++ int getv0_itry; // getv0 flow control internal ++ int getv0_orth; // getv0 flow control internal ++ int aitr_iter; // naitr flow control internal ++ int aitr_j; // naitr flow control internal ++ int aitr_orth1; // naitr flow control internal ++ int aitr_orth2; // naitr flow control internal ++ int aitr_restart; // naitr flow control internal ++ int aitr_step3; // naitr flow control internal ++ int aitr_step4; // naitr flow control internal ++ int aitr_ierr; // naitr flow control internal ++ int aup2_initv; // naupd2 flow control internal ++ int aup2_iter; // naupd2 flow control internal ++ int aup2_getv0; // naupd2 flow control internal ++ int aup2_cnorm; // naupd2 flow control internal ++ int aup2_kplusp; // naupd2 flow control internal ++ int aup2_nev0; // naupd2 internal compute internal ++ int aup2_np0; // naupd2 internal compute internal ++ int aup2_numcnv; // naupd2 internal compute internal ++ int aup2_update; // naupd2 flow control internal ++ int aup2_ushift; // naupd2 flow control internal ++}; ++ ++ ++void ARPACK_snaupd(struct ARPACK_arnoldi_update_vars_s *V, float* resid, float* v, int ldv, int* ipntr, float* workd, float* workl); ++void ARPACK_dnaupd(struct ARPACK_arnoldi_update_vars_d *V, double* resid, double* v, int ldv, int* ipntr, double* workd, double* workl); ++void ARPACK_cnaupd(struct ARPACK_arnoldi_update_vars_s *V, ARPACK_CPLXF_TYPE* resid, ARPACK_CPLXF_TYPE* v, int ldv, int* ipntr, ARPACK_CPLXF_TYPE* workd, ARPACK_CPLXF_TYPE* workl, float* rwork); ++void ARPACK_znaupd(struct ARPACK_arnoldi_update_vars_d *V, ARPACK_CPLX_TYPE* resid, ARPACK_CPLX_TYPE* v, int ldv, int* ipntr, ARPACK_CPLX_TYPE* workd, ARPACK_CPLX_TYPE* workl, double* rwork); ++ ++void ARPACK_sneupd(struct ARPACK_arnoldi_update_vars_s *V, int rvec, int howmny, int* select, float* dr, float* di, float* z, int ldz, float sigmar, float sigmai, float* workev, float* resid, float* v, int ldv, int* ipntr, float* workd, float* workl); ++void ARPACK_dneupd(struct ARPACK_arnoldi_update_vars_d *V, int rvec, int howmny, int* select, double* dr, double* di, double* z, int ldz, double sigmar, double sigmai, double* workev, double* resid, double* v, int ldv, int* ipntr, double* workd, double* workl); ++void ARPACK_cneupd(struct ARPACK_arnoldi_update_vars_s *V, int rvec, int howmny, int* select, ARPACK_CPLXF_TYPE* d, ARPACK_CPLXF_TYPE* z, int ldz, ARPACK_CPLXF_TYPE sigma, ARPACK_CPLXF_TYPE* workev, ARPACK_CPLXF_TYPE* resid, ARPACK_CPLXF_TYPE* v, int ldv, int* ipntr, ARPACK_CPLXF_TYPE* workd, ARPACK_CPLXF_TYPE* workl, float* rwork); ++void ARPACK_zneupd(struct ARPACK_arnoldi_update_vars_d *V, int rvec, int howmny, int* select, ARPACK_CPLX_TYPE* d, ARPACK_CPLX_TYPE* z, int ldz, ARPACK_CPLX_TYPE sigma, ARPACK_CPLX_TYPE* workev, ARPACK_CPLX_TYPE* resid, ARPACK_CPLX_TYPE* v, int ldv, int* ipntr, ARPACK_CPLX_TYPE* workd, ARPACK_CPLX_TYPE* workl, double* rwork); ++ ++void ARPACK_ssaupd(struct ARPACK_arnoldi_update_vars_s *V, float* resid, float* v, int ldv, int* ipntr, float* workd, float* workl); ++void ARPACK_dsaupd(struct ARPACK_arnoldi_update_vars_d *V, double* resid, double* v, int ldv, int* ipntr, double* workd, double* workl); ++ ++void ARPACK_sseupd(struct ARPACK_arnoldi_update_vars_s *V, int rvec, int howmny, int* select, float* d, float* z, int ldz, float sigma, float* resid, float* v, int ldv, int* ipntr, float* workd, float* workl); ++void ARPACK_dseupd(struct ARPACK_arnoldi_update_vars_d *V, int rvec, int howmny, int* select, double* d, double* z, int ldz, double sigma, double* resid, double* v, int ldv, int* ipntr, double* workd, double* workl); ++ ++#endif /* ifndef */ +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.c b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.c +new file mode 100644 +index 0000000000..25c85b2602 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.c +@@ -0,0 +1,2101 @@ ++#include "_arpack_n_double.h" ++ ++typedef int ARPACK_compare_cfunc(const double, const double, const double, const double); ++ ++static int sortc_LM(const double, const double, const double, const double); ++static int sortc_SM(const double, const double, const double, const double); ++static int sortc_LR(const double, const double, const double, const double); ++static int sortc_SR(const double, const double, const double, const double); ++static int sortc_LI(const double, const double, const double, const double); ++static int sortc_SI(const double, const double, const double, const double); ++ ++static const double unfl = 2.2250738585072014e-308; ++// static const double ovfl = 1.0 / 2.2250738585072014e-308; ++static const double ulp = 2.220446049250313e-16; ++ ++static void dnaup2(struct ARPACK_arnoldi_update_vars_d*, double*, double*, int, double*, int, double*, double*, double*, double*, int, double*, int*, double*); ++static void dnconv(int n, double* ritzr, double* ritzi, double* bounds, const double tol, int* nconv); ++static void dneigh(double*,int,double*,int,double*,double*,double*,double*,int,double*,int*); ++static void dnaitr(struct ARPACK_arnoldi_update_vars_d*,int,int,double*,double*,double*,int,double*,int,int*,double*); ++static void dnapps(int,int*,int,double*,double*,double*,int,double*,int,double*,double*,int,double*,double*); ++static void dngets(struct ARPACK_arnoldi_update_vars_d*,int*,int*,double*,double*,double*); ++static void dsortc(const enum ARPACK_which w, const int apply, const int n, double* xreal, double* ximag, double* y); ++static void dgetv0(struct ARPACK_arnoldi_update_vars_d *V, int initv, int n, int j, double* v, int ldv, double* resid, double* rnorm, int* ipntr, double* workd); ++ ++enum ARPACK_neupd_type { ++ REGULAR = 0, ++ SHIFTI, ++ REALPART, ++ IMAGPART ++}; ++ ++ ++void ++ARPACK_dneupd(struct ARPACK_arnoldi_update_vars_d *V, int rvec, int howmny, int* select, ++ double* dr, double* di, double* z, int ldz, double sigmar, double sigmai, ++ double* workev, double* resid, double* v, int ldv, int* ipntr, double* workd, ++ double* workl) ++{ ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ int ibd, iconj, ih, iheigr, iheigi, ihbds, iuptri, invsub, iri, irr, j, jj; ++ int bounds, k, ldh, ldq, np, numcnv, reord, ritzr, ritzi; ++ int iwork[1] = { 0 }; ++ int ierr = 0, int1 = 1, tmp_int = 0, nconv2 = 0, outncv; ++ double conds, rnorm, sep, temp, temp1, dbl0 = 0.0, dbl1 = 1.0, dblm1 = -1.0; ++ double vl[1] = { 0.0 }; ++ enum ARPACK_neupd_type TYP; ++ ++ if (V->nconv <= 0) { ++ ierr = -14; ++ } else if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv <= V->nev + 1) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if ((V->which > 5) || (V->which < 0)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((rvec) && ((howmny < 0) || (howmny > 2))) { ++ ierr = -13; ++ } else if (howmny == 2) { ++ ierr = -12; // NotImplementedError ++ } ++ ++ if ((V->mode == 1) || (V->mode == 2)) { ++ TYP = REGULAR; ++ } else if ((V->mode == 3) && (sigmai == 0.0)) { ++ TYP = SHIFTI; ++ } else if (V->mode == 3) { ++ TYP = REALPART; ++ } else if (V->mode == 4) { ++ TYP = IMAGPART; ++ } else { ++ ierr = -10; ++ } ++ ++ if ((V->mode == 1) && (V->bmat)) { ierr = -11; } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ return; ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:ncv*ncv) := generated Hessenberg matrix ++ // workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary parts of ritz values ++ // workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds ++ ++ // The following is used and set by DNEUPD . ++ // workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed real part of the Ritz values. ++ // workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed imaginary part of the Ritz values. ++ // workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed error bounds of the Ritz values ++ // workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper quasi-triangular matrix for H ++ // workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the associated matrix representation of the invariant subspace for H. ++ // GRAND total of NCV * ( 3 * NCV + 6 ) locations. ++ ++ ih = ipntr[4]; ++ ritzr = ipntr[5]; ++ ritzi = ipntr[6]; ++ bounds = ipntr[7]; ++ ldh = V->ncv; ++ ldq = V->ncv; ++ iheigr = bounds + ldh; ++ iheigi = iheigr + ldh; ++ ihbds = iheigi + ldh; ++ iuptri = ihbds + ldh; ++ invsub = iuptri + ldh*V->ncv; ++ ipntr[8] = iheigr; ++ ipntr[9] = iheigi; ++ ipntr[10] = ihbds; ++ ipntr[11] = iuptri; ++ ipntr[12] = invsub; ++ ++ // irr points to the REAL part of the Ritz ++ // values computed by _neigh before ++ // exiting _naup2. ++ // iri points to the IMAGINARY part of the ++ // Ritz values computed by _neigh ++ // before exiting _naup2. ++ // ibd points to the Ritz estimates ++ // computed by _neigh before exiting ++ // _naup2. ++ ++ irr = ipntr[13] + (V->ncv)*(V->ncv); ++ iri = irr + V->ncv; ++ ibd = iri + V->ncv; ++ ++ // RNORM is B-norm of the RESID(1:N). ++ rnorm = workl[ih+2]; ++ workl[ih+2] = 0.0; ++ ++ if (rvec) { ++ reord = 0; ++ ++ // Use the temporary bounds array to store indices ++ // These will be used to mark the select array later ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[bounds + j] = j; ++ select[j] = 0; ++ } ++ // 10 ++ ++ // Select the wanted Ritz values. ++ // Sort the Ritz values so that the ++ // wanted ones appear at the tailing ++ // NEV positions of workl(irr) and ++ // workl(iri). Move the corresponding ++ // error estimates in workl(bound) ++ // accordingly. ++ ++ np = V->ncv - V->nev; ++ dngets(V, &V->nev, &np, &workl[irr], &workl[iri], &workl[bounds]); ++ ++ // Record indices of the converged wanted Ritz values ++ // Mark the select array for possible reordering ++ ++ numcnv = 0; ++ for (j = 1; j <= V->ncv; j++) ++ { ++ temp1 = fmax(eps23, hypot(workl[irr + V->ncv - j], workl[iri + V->ncv - j])); ++ ++ jj = (int)workl[bounds + V->ncv - j]; ++ ++ if ((numcnv < V->nconv) && (workl[ibd + jj] <= V->tol*temp1)) ++ { ++ select[jj] = 1; ++ numcnv += 1; ++ if (jj > V->nconv - 1) { reord = 1; } ++ } ++ } ++ // 11 ++ ++ // Check the count (numcnv) of converged Ritz values with ++ // the number (nconv) reported by dnaupd. If these two ++ // are different then there has probably been an error ++ // caused by incorrect passing of the dnaupd data. ++ ++ if (numcnv != V->nconv) ++ { ++ V->info = -15; ++ return; ++ } ++ ++ // Call LAPACK routine dlahqr to compute the real Schur form ++ // of the upper Hessenberg matrix returned by DNAUPD . ++ // Make a copy of the upper Hessenberg matrix. ++ // Initialize the Schur vector matrix Q to the identity. ++ ++ tmp_int = ldh*V->ncv; ++ dcopy_(&tmp_int, &workl[ih], &int1, &workl[iuptri], &int1); ++ dlaset_("A", &V->ncv, &V->ncv, &dbl0, &dbl1, &workl[invsub], &ldq); ++ dlahqr_(&int1, &int1, &V->ncv, &int1, &V->ncv, &workl[iuptri], &ldh, ++ &workl[iheigr], &workl[iheigi], &int1, &V->ncv, &workl[invsub], ++ &ldq, &ierr); ++ dcopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ if (ierr != 0) ++ { ++ V->info = -8; ++ return; ++ } ++ ++ if (reord) ++ { ++ dtrsen_("N", "V", select, &V->ncv, &workl[iuptri], &ldh, &workl[invsub], &ldq, ++ &workl[iheigr], &workl[iheigi], &nconv2, &conds, &sep, &workl[ihbds], ++ &V->ncv, iwork, &int1, &ierr); ++ ++ if (nconv2 < V->nconv) { V->nconv = nconv2; } ++ if (ierr == 1) { ++ V->info = 1; ++ return; ++ } ++ } ++ ++ // Copy the last row of the Schur vector ++ // into workl(ihbds). This will be used ++ // to compute the Ritz estimates of ++ // converged Ritz values. ++ ++ dcopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ // Place the computed eigenvalues of H into DR and DI ++ // if a spectral transformation was not used. ++ ++ if (TYP == REGULAR) { ++ dcopy_(&V->nconv, &workl[iheigr], &int1, dr, &int1); ++ dcopy_(&V->nconv, &workl[iheigi], &int1, di, &int1); ++ } ++ ++ // Compute the QR factorization of the matrix representing ++ // the wanted invariant subspace located in the first NCONV ++ // columns of workl(invsub,ldq). ++ ++ dgeqr2_(&V->ncv, &V->nconv, &workl[invsub], &ldq, workev, &workev[V->ncv], &ierr); ++ ++ // * Postmultiply V by Q using dorm2r . ++ // * Copy the first NCONV columns of VQ into Z. ++ // * Postmultiply Z by R. ++ // The N by NCONV matrix Z is now a matrix representation ++ // of the approximate invariant subspace associated with ++ // the Ritz values in workl(iheigr) and workl(iheigi) ++ // The first NCONV columns of V are now approximate Schur ++ // vectors associated with the real upper quasi-triangular ++ // matrix of order NCONV in workl(iuptri) ++ ++ dorm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[invsub], &ldq, workev, ++ v, &ldv, &workd[V->n], &ierr); ++ ++ dlacpy_("A", &V->n, &V->nconv, v, &ldv, z, &ldz); ++ ++ // Perform both a column and row scaling if the ++ // diagonal element of workl(invsub,ldq) is negative ++ // I'm lazy and don't take advantage of the upper ++ // quasi-triangular form of workl(iuptri,ldq) ++ // Note that since Q is orthogonal, R is a diagonal ++ // matrix consisting of plus or minus ones ++ ++ for (j = 0; j < V->nconv; j++) ++ { ++ if (workl[invsub + j*ldq + j] < 0.0) ++ { ++ dscal_(&V->nconv, &dblm1, &workl[iuptri + j], &ldq); ++ dscal_(&V->nconv, &dblm1, &workl[iuptri + j*ldq], &int1); ++ } ++ } ++ // 20 ++ ++ if (howmny == 0) ++ { ++ ++ // Compute the NCONV wanted eigenvectors of T ++ // located in workl(iuptri,ldq). ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ if (j < V->nconv) ++ { ++ select[j] = 1; ++ } else { ++ select[j] = 0; ++ } ++ } ++ // 30 ++ ++ dtrevc_("R", "S", select, &V->ncv, &workl[iuptri], &ldq, vl, &int1, ++ &workl[invsub], &ldq, &V->ncv, &outncv, workev, &ierr); ++ ++ if (ierr != 0) ++ { ++ V->info = -9; ++ return; ++ } ++ ++ // Scale the returning eigenvectors so that their ++ // Euclidean norms are all one. LAPACK subroutine ++ // dtrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1; ++ ++ iconj = 0; ++ for (j = 0; j < V->nconv; j++) ++ { ++ if (workl[iheigi + j] == 0.0) ++ { ++ ++ // real eigenvalue case ++ ++ temp = 1.0 / dnrm2_(&V->ncv, &workl[invsub + j*ldq], &int1); ++ dscal_(&V->ncv, &temp, &workl[invsub + j*ldq], &int1); ++ ++ } else { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ // columns, we further normalize by the ++ // square root of two. ++ ++ if (iconj == 0) ++ { ++ temp = 1.0 / hypot(dnrm2_(&V->ncv, &workl[invsub + j*ldq], &int1), ++ dnrm2_(&V->ncv, &workl[invsub + (j+1)*ldq], &int1)); ++ dscal_(&V->ncv, &temp, &workl[invsub + j*ldq], &int1); ++ dscal_(&V->ncv, &temp, &workl[invsub + (j+1)*ldq], &int1); ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 40 ++ ++ dgemv_("T", &V->ncv, &V->nconv, &dbl1, &workl[invsub], &ldq, &workl[ihbds], &int1, &dbl0, workev, &int1); ++ ++ iconj = 0; ++ for (j = 0; j < V->nconv; j++) ++ { ++ if (workl[iheigi + j] != 0.0) ++ { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ ++ if (iconj == 0) ++ { ++ workev[j] = hypot(workev[j], workev[j+1]); ++ workev[j+1] = workev[j]; ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 45 ++ ++ // Copy Ritz estimates into workl(ihbds) ++ ++ dcopy_(&V->nconv, workev, &int1, &workl[ihbds], &int1); ++ ++ // Compute the QR factorization of the eigenvector matrix ++ // associated with leading portion of T in the first NCONV ++ // columns of workl(invsub,ldq). ++ ++ dgeqr2_(&V->ncv, &V->nconv, &workl[invsub], &ldq, workev, &workev[V->ncv], &ierr); ++ ++ // * Postmultiply Z by Q. ++ // * Postmultiply Z by R. ++ // The N by NCONV matrix Z is now contains the ++ // Ritz vectors associated with the Ritz values ++ // in workl(iheigr) and workl(iheigi). ++ ++ dorm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[invsub], &ldq, ++ workev, z, &ldz, &workd[V->n], &ierr); ++ ++ dtrmm_("R", "U", "N", "N", &V->n, &V->nconv, &dbl1, &workl[invsub], &ldq, z, &ldz); ++ ++ } ++ ++ } else { ++ ++ // An approximate invariant subspace is not needed. ++ // Place the Ritz values computed DNAUPD into DR and DI ++ ++ dcopy_(&V->nconv, &workl[ritzr], &int1, dr, &int1); ++ dcopy_(&V->nconv, &workl[ritzi], &int1, di, &int1); ++ dcopy_(&V->nconv, &workl[ritzr], &int1, &workl[iheigr], &int1); ++ dcopy_(&V->nconv, &workl[ritzi], &int1, &workl[iheigi], &int1); ++ dcopy_(&V->nconv, &workl[bounds], &int1, &workl[ihbds], &int1); ++ } ++ ++ // Transform the Ritz values and possibly vectors ++ // and corresponding error bounds of OP to those ++ // of A*x = lambda*B*x. ++ ++ if (TYP == REGULAR) ++ { ++ if (rvec) ++ { ++ dscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ } else { ++ ++ // A spectral transformation was used. ++ // * Determine the Ritz estimates of the ++ // Ritz values in the original system. ++ ++ if (TYP == SHIFTI) ++ { ++ if (rvec) ++ { ++ dscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ ++ for (k = 0; k < V->ncv; k++) ++ { ++ temp = hypot(workl[iheigr+k], workl[iheigi+k]); ++ workl[ihbds+k] = fabs(workl[ihbds+k]) / temp / temp; ++ } ++ // 50 ++ ++ } ++ ++ // * Transform the Ritz values back to the original system. ++ // For TYPE = 'SHIFTI' the transformation is ++ // lambda = 1/theta + sigma ++ // For TYPE = 'REALPT' or 'IMAGPT' the user must from ++ // Rayleigh quotients or a projection. See remark 3 above. ++ // NOTES: ++ // *The Ritz vectors are not affected by the transformation. ++ ++ if (TYP == SHIFTI) ++ { ++ for (k = 0; k < V->ncv; k++) ++ { ++ temp = hypot(workl[iheigr+k], workl[iheigi+k]); ++ workl[iheigr+k] = workl[iheigr+k] / temp / temp + sigmar; ++ workl[iheigi+k] = -workl[iheigi+k] / temp / temp + sigmai; ++ } ++ // 80 ++ ++ dcopy_(&V->nconv, &workl[iheigr], &int1, dr, &int1); ++ dcopy_(&V->nconv, &workl[iheigi], &int1, di, &int1); ++ ++ } else if ((TYP == REALPART) || (TYP == IMAGPART)) { ++ dcopy_(&V->nconv, &workl[iheigr], &int1, dr, &int1); ++ dcopy_(&V->nconv, &workl[iheigi], &int1, di, &int1); ++ } ++ } ++ ++ // Eigenvector Purification step. Formally perform ++ // one of inverse subspace iteration. Only used ++ // for MODE = 2. ++ ++ if ((rvec) && (howmny == 0) && (TYP == SHIFTI)) ++ { ++ ++ // Purify the computed Ritz vectors by adding a ++ // little bit of the residual vector: ++ // T ++ // resid(:)*( e s ) / theta ++ // NCV ++ // where H s = s theta. Remember that when theta ++ // has nonzero imaginary part, the corresponding ++ // Ritz vector is stored across two columns of Z. ++ ++ iconj = 0; ++ for (j = 0; j < V->nconv; j++) ++ { ++ if ((workl[iheigi+j] == 0.0) && (workl[iheigr+j] != 0.0)) ++ { ++ workev[j] = workl[invsub + j*ldq + V->ncv] / workl[iheigr+j]; ++ } else if (iconj == 0) { ++ ++ temp = hypot(workl[iheigr+j], workl[iheigi+j]); ++ if (temp != 0.0) ++ { ++ workev[j] = (workl[invsub + j*ldq + V->ncv]*workl[iheigr+j] + ++ workl[invsub + (j+1)*ldq + V->ncv]*workl[iheigi+j] ++ ) / temp / temp; ++ workev[j+1] = (workl[invsub + (j+1)*ldq + V->ncv]*workl[iheigr+j] - ++ workl[invsub + j*ldq + V->ncv]*workl[iheigi+j] ++ ) / temp / temp; ++ } ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ // 110 ++ ++ // Perform a rank one update to Z and ++ // purify all the Ritz vectors together. ++ ++ dger_(&V->n, &V->nconv, &dbl1, resid, &int1, workev, &int1, z, &ldz); ++ } ++ ++ return; ++} ++ ++void ++ARPACK_dnaupd(struct ARPACK_arnoldi_update_vars_d *V, double* resid, double* v, ++ int ldv, int* ipntr, double* workd, double* workl) ++{ ++ int bounds, ih, iq, iw, j, ldh, ldq, next, iritzi, iritzr; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // perform basic checks ++ if (V->n <= 0) { ++ V->info = -1; ++ } else if (V->nev <= 0) { ++ V->info = -2; ++ } else if ((V->ncv < V->nev + 1) || (V->ncv > V->n)) { ++ V->info = -3; ++ } else if (V->maxiter <= 0) { ++ V->info = -4; ++ } else if ((V->which < 0) || (V->which > 5)) { ++ V->info = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ V->info = -6; ++ } else if ((V->mode < 1) || (V->mode > 4)) { ++ V->info = -10; ++ } else if ((V->mode == 1) && (V->bmat == 1)) { ++ V->info = -11; ++ } else if ((V->shift != 0) && (V->shift != 1)) { ++ V->info = -12; ++ } ++ ++ if (V->info < 0) { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ if (V->tol <= 0.0) { ++ V->tol = ulp; ++ } ++ V->np = V->ncv - V->nev; ++ ++ for (j = 0; j < 3 * (V->ncv)*(V->ncv) + 6*(V->ncv); j++) ++ { ++ workl[j] = 0.0; ++ } ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // ++ // workl[0:ncv*ncv] := generated Hessenberg matrix ++ // workl[ncv**2:ncv**2+2*ncv] := ritz.real and ritz.imag values ++ // workl[ncv**2+2*ncv:ncv*ncv+3*ncv] := error bounds ++ // workl[ncv**2+3*ncv+1:2*ncv*ncv+3*ncv] := rotation matrix Q ++ // workl[2*ncv**2+3*ncv:3*ncv*ncv+6*ncv] := workspace ++ // ++ // The final workspace is needed by subroutine dneigh called ++ // by dnaup2 . Subroutine dneigh calls LAPACK routines for ++ // calculating eigenvalues and the last row of the eigenvector ++ // matrix. ++ ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ih = 0; ++ iritzr = ih + ldh*V->ncv; ++ iritzi = iritzr + V->ncv; ++ bounds = iritzi + V->ncv; ++ iq = bounds + V->ncv; ++ iw = iq + ldq*V->ncv; ++ next = iw + (V->ncv*V->ncv) + 3*V->ncv; ++ ++ ipntr[3] = next; ++ ipntr[4] = ih; ++ ipntr[5] = iritzr; ++ ipntr[6] = iritzi; ++ ipntr[7] = bounds; ++ ipntr[13] = iw; ++ ++ // Carry out the Implicitly restarted Arnoldi Iteration. ++ ++ dnaup2(V, resid, v, ldv, &workl[ih], ldh, &workl[iritzr], &workl[iritzi], &workl[bounds], &workl[iq], ldq, &workl[iw], ipntr, workd); ++ ++ // ido != DONE implies use of reverse communication ++ // to compute operations involving OP or shifts. ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ V->nconv = V->np; ++ // iparam(9) = nopx ++ // iparam(10) = nbx ++ // iparam(11) = nrorth ++ ++ if (V->info < 0) { return; } ++ if (V->info == 2) { V->info = 3; } ++ ++ return; ++} ++ ++void ++dnaup2(struct ARPACK_arnoldi_update_vars_d *V, double* resid, double* v, int ldv, ++ double* h, int ldh, double* ritzr, double* ritzi, double* bounds, ++ double* q, int ldq, double* workl, int* ipntr, double* workd) ++{ ++ enum ARPACK_which temp_which; ++ int int1 = 1, j, tmp_int; ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ double temp = 0.0; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->aup2_nev0 = V->nev; ++ V->aup2_np0 = V->np; ++ ++ // kplusp is the bound on the largest ++ // Lanczos factorization built. ++ // nconv is the current number of ++ // "converged" eigenvlues. ++ // iter is the counter on the current ++ // iteration step. ++ ++ V->aup2_kplusp = V->nev + V->np; ++ V->nconv = 0; ++ V->aup2_iter = 0; ++ ++ // Set flags for computing the first NEV ++ // steps of the Arnoldi factorization. ++ ++ V->aup2_getv0 = 1; ++ V->aup2_update = 0; ++ V->aup2_ushift = 0; ++ V->aup2_cnorm = 0; ++ ++ if (V->info != 0) ++ { ++ ++ // User provides the initial residual vector. ++ ++ V->aup2_initv = 1; ++ V->info = 0; ++ } else { ++ V->aup2_initv = 0; ++ } ++ } ++ ++ // Get a possibly random starting vector and ++ // force it into the range of the operator OP. ++ ++ if (V->aup2_getv0) ++ { ++ V->getv0_itry = 1; ++ dgetv0(V, V->aup2_initv, V->n, 0, v, ldv, resid, &V->aup2_rnorm, ipntr, workd); ++ if (V->ido != ido_DONE) { return; } ++ if (V->aup2_rnorm == 0.0) ++ { ++ V->info = -9; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_getv0 = 0; ++ V->ido = ido_FIRST; ++ } ++ ++ // Back from reverse communication : ++ // continue with update step ++ ++ if (V->aup2_update) { goto LINE20; } ++ ++ // Back from computing user specified shifts ++ ++ if (V->aup2_ushift) { goto LINE50; } ++ ++ // Back from computing residual norm ++ // at the end of the current iteration ++ ++ if (V->aup2_cnorm) { goto LINE100; } ++ ++ // Compute the first NEV steps of the Arnoldi factorization ++ ++ dnaitr(V, 0, V->nev, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // ++ // M A I N ARNOLDI I T E R A T I O N L O O P ++ // Each iteration implicitly restarts the Arnoldi ++ // factorization in place. ++ // ++ ++LINE1000: ++ V->aup2_iter += 1; ++ ++ // Compute NP additional steps of the Arnoldi factorization. ++ // Adjust NP since NEV might have been updated by last call ++ // to the shift application routine dnapps . ++ ++ V->np = V->aup2_kplusp - V->nev; ++ ++ // Compute NP additional steps of the Arnoldi factorization. ++ ++ V->ido = ido_FIRST; ++ ++LINE20: ++ V->aup2_update = 1; ++ ++ dnaitr(V, V->nev, V->np, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_update = 0; ++ ++ // Compute the eigenvalues and corresponding error bounds ++ // of the current upper Hessenberg matrix. ++ ++ dneigh(&V->aup2_rnorm, V->aup2_kplusp, h, ldh, ritzr, ritzi, bounds, q, ldq, workl, &V->info); ++ ++ if (V->info != 0) ++ { ++ V->info = -8; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Make a copy of eigenvalues and corresponding error ++ // bounds obtained from dneigh. ++ ++ tmp_int = V->aup2_kplusp * V->aup2_kplusp; ++ dcopy_(&V->aup2_kplusp, ritzr, &int1, &workl[tmp_int], &int1); ++ tmp_int += V->aup2_kplusp; ++ dcopy_(&V->aup2_kplusp, ritzi, &int1, &workl[tmp_int], &int1); ++ tmp_int += V->aup2_kplusp; ++ dcopy_(&V->aup2_kplusp, bounds, &int1, &workl[tmp_int], &int1); ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The wanted part of the spectrum and corresponding ++ // error bounds are in the last NEV loc. of RITZR, ++ // RITZI and BOUNDS respectively. The variables NEV ++ // and NP may be updated if the NEV-th wanted Ritz ++ // value has a non zero imaginary part. In this case ++ // NEV is increased by one and NP decreased by one. ++ // NOTE: The last two arguments of dngets are no ++ // longer used as of version 2.1. ++ ++ V->nev = V->aup2_nev0; ++ V->np = V->aup2_np0; ++ V->aup2_numcnv = V->nev; ++ ++ dngets(V, &V->nev, &V->np, ritzr, ritzi, bounds); ++ ++ if (V->nev == V->aup2_nev0 + 1) { V->aup2_numcnv = V->aup2_nev0 + 1;} ++ ++ // Convergence test. ++ ++ dcopy_(&V->nev, &bounds[V->np], &int1, &workl[2*V->np], &int1); ++ dnconv(V->nev, &ritzr[V->np], &ritzi[V->np], &workl[2*V->np], V->tol, &V->nconv); ++ ++ // Count the number of unwanted Ritz values that have zero ++ // Ritz estimates. If any Ritz estimates are equal to zero ++ // then a leading block of H of order equal to at least ++ // the number of Ritz values with zero Ritz estimates has ++ // split off. None of these Ritz values may be removed by ++ // shifting. Decrease NP the number of shifts to apply. If ++ // no shifts may be applied, then prepare to exit ++ ++ // We are modifying V->np hence the temporary variable. ++ int nptemp = V->np; ++ ++ for (j = 0; j < nptemp; j++) ++ { ++ if (bounds[j] == 0.0) ++ { ++ V->np -= 1; ++ V->nev += 1; ++ } ++ } ++ // 30 ++ ++ if ((V->nconv >= V->aup2_numcnv) || (V->aup2_iter > V->maxiter) || (V->np == 0)) ++ { ++ ++ // Prepare to exit. Put the converged Ritz values ++ // and corresponding bounds in RITZ(1:NCONV) and ++ // BOUNDS(1:NCONV) respectively. Then sort. Be ++ // careful when NCONV > NP ++ ++ // Use h( 3,1 ) as storage to communicate ++ // rnorm to _neupd if needed ++ ++ h[2] = V->aup2_rnorm; ++ ++ // To be consistent with dngets , we first do a ++ // pre-processing sort in order to keep complex ++ // conjugate pairs together. This is similar ++ // to the pre-processing sort used in dngets ++ // except that the sort is done in the opposite ++ // order. ++ ++ // Translation note: Is this all because ARPACK did not have complex sort? ++ ++ if (V->which == which_LM) { temp_which = which_SR; } ++ if (V->which == which_SM) { temp_which = which_LR; } ++ if (V->which == which_LR) { temp_which = which_SM; } ++ if (V->which == which_SR) { temp_which = which_LM; } ++ if (V->which == which_LI) { temp_which = which_SM; } ++ if (V->which == which_SI) { temp_which = which_LM; } ++ ++ dsortc(temp_which, 1, V->aup2_kplusp, ritzr, ritzi, bounds); ++ ++ if (V->which == which_LM) { temp_which = which_SM; } ++ if (V->which == which_SM) { temp_which = which_LM; } ++ if (V->which == which_LR) { temp_which = which_SR; } ++ if (V->which == which_SR) { temp_which = which_LR; } ++ if (V->which == which_LI) { temp_which = which_SI; } ++ if (V->which == which_SI) { temp_which = which_LI; } ++ ++ dsortc(temp_which, 1, V->aup2_kplusp, ritzr, ritzi, bounds); ++ ++ // Scale the Ritz estimate of each Ritz value ++ // by 1 / max(eps23,magnitude of the Ritz value). ++ ++ for (j = 0; j < V->aup2_numcnv; j++) ++ { ++ temp = fmax(eps23, hypot(ritzr[j], ritzi[j])); ++ bounds[j] = bounds[j] / temp; ++ } ++ // 35 ++ ++ // Sort the Ritz values according to the scaled Ritz ++ // estimates. This will push all the converged ones ++ // towards the front of ritzr, ritzi, bounds ++ // (in the case when NCONV < NEV.) ++ ++ temp_which = which_LR; ++ dsortc(temp_which, 1, V->aup2_numcnv, bounds, ritzr, ritzi); ++ ++ // Scale the Ritz estimate back to its original ++ // value. ++ ++ for (j = 0; j < V->aup2_numcnv; j++) ++ { ++ temp = fmax(eps23, hypot(ritzr[j], ritzi[j])); ++ bounds[j] = bounds[j] * temp; ++ } ++ // 40 ++ ++ // Sort the converged Ritz values again so that ++ // the "threshold" value appears at the front of ++ // ritzr, ritzi and bound. ++ ++ dsortc(V->which, 1, V->nconv, ritzr, ritzi, bounds); ++ ++ if ((V->aup2_iter > V->maxiter) && (V->nconv < V->aup2_numcnv)) ++ { ++ ++ // Max iterations have been exceeded. ++ ++ V->info = 1; ++ } ++ ++ if ((V->np == 0) && (V->nconv < V->aup2_numcnv)) ++ { ++ ++ // No shifts to apply. ++ ++ V->info = 2; ++ } ++ ++ V->np = V->nconv; ++ V->iter = V->aup2_iter; ++ V->nev = V->aup2_numcnv; ++ V->ido = ido_DONE; ++ return; ++ ++ } else if ((V->nconv < V->aup2_numcnv) && (V->shift)) { ++ ++ // Do not have all the requested eigenvalues yet. ++ // To prevent possible stagnation, adjust the size ++ // of NEV. ++ ++ int nevbef = V->nev; ++ V->nev += (V->nconv > (V->np / 2) ? (V->np / 2) : V->nconv); ++ if ((V->nev == 1) && (V->aup2_kplusp >= 6)) { ++ V->nev = V->aup2_kplusp / 2; ++ } else if ((V->nev == 1) && (V->aup2_kplusp > 3)) { ++ V->nev = 2; ++ } ++ ++ // SciPy Fix ++ // We must keep nev below this value, as otherwise we can get ++ // np == 0 (note that dngets below can bump nev by 1). If np == 0, ++ // the next call to `dnaitr` will write out-of-bounds. ++ ++ if (V->nev > (V->aup2_kplusp - 2)) { ++ V->nev = V->aup2_kplusp - 2; ++ } ++ // SciPy Fix End ++ ++ V->np = V->aup2_kplusp - V->nev; ++ ++ if (nevbef < V->nev) { ++ dngets(V, &V->nev, &V->np, ritzr, ritzi, bounds); ++ } ++ ++ } ++ ++ if (V->shift == 0) ++ { ++ ++ // User specified shifts: reverse communication to ++ // compute the shifts. They are returned in the first ++ // 2*NP locations of WORKL. ++ ++ V->aup2_ushift = 1; ++ V->ido = ido_USER_SHIFT; ++ return; ++ } ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // User specified shifts are returned ++ // in WORKL(1:2*NP) ++ ++ V->aup2_ushift = 0; ++ ++ if (V->shift == 0) ++ { ++ ++ // Move the NP shifts from WORKL to ++ // RITZR, RITZI to free up WORKL ++ // for non-exact shift case. ++ ++ dcopy_(&V->np, workl, &int1, ritzr, &int1); ++ dcopy_(&V->np, &workl[V->np], &int1, ritzi, &int1); ++ } ++ ++ // Apply the NP implicit shifts by QR bulge chasing. ++ // Each shift is applied to the whole upper Hessenberg ++ // matrix H. ++ // The first 2*N locations of WORKD are used as workspace. ++ ++ dnapps(V->n, &V->nev, V->np, ritzr, ritzi, v, ldv, h, ldh, resid, q, ldq, workl, workd); ++ ++ // Compute the B-norm of the updated residual. ++ // Keep B*RESID in WORKD(1:N) to be used in ++ // the first step of the next call to dnaitr . ++ ++ V->aup2_cnorm = 1; ++ if (V->bmat) ++ { ++ dcopy_(&V->n, resid, &int1, &workd[V->n], &int1); ++ ipntr[0] = V->n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*RESID ++ ++ return; ++ } else { ++ dcopy_(&V->n, resid, &int1, workd, &int1); ++ } ++ ++LINE100: ++ ++ // Back from reverse communication; ++ // WORKD(1:N) := B*RESID ++ ++ if (V->bmat) ++ { ++ V->aup2_rnorm = ddot_(&V->n, resid, &int1, workd, &int1); ++ V->aup2_rnorm = sqrt(fabs(V->aup2_rnorm)); ++ } else { ++ V->aup2_rnorm = dnrm2_(&V->n, resid, &int1); ++ } ++ V->aup2_cnorm = 0; ++ ++ goto LINE1000; ++ ++ // ++ // E N D O F M A I N I T E R A T I O N L O O P ++ // ++ ++} ++ ++void ++dnconv(int n, double* ritzr, double* ritzi, double* bounds, const double tol, int* nconv) ++{ ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ double temp; ++ ++ *nconv = 0; ++ for (int i = 0; i < n; i++) ++ { ++ temp = fmax(eps23, hypot(ritzr[i], ritzi[i])); ++ if (bounds[i] <= tol*temp) ++ { ++ *nconv += 1; ++ } ++ } ++ ++ return; ++} ++ ++void ++dneigh(double* rnorm, int n, double* h, int ldh, double* ritzr, double* ritzi, ++ double* bounds, double* q, int ldq, double* workl, int* ierr) ++{ ++ int select[1] = { 0 }; ++ int i, iconj, int1 = 1, j; ++ double dbl1 = 1.0, dbl0 = 0.0, temp, tmp_dbl, vl[1] = { 0.0 }; ++ ++ // 1. Compute the eigenvalues, the last components of the ++ // corresponding Schur vectors and the full Schur form T ++ // of the current upper Hessenberg matrix H. ++ // dlahqr returns the full Schur form of H in WORKL(1:N**2) ++ // and the last components of the Schur vectors in BOUNDS. ++ ++ dlacpy_("A", &n, &n, h, &ldh, workl, &n); ++ for (j = 0; j < n-1; j++) ++ { ++ bounds[j] = 0.0; ++ } ++ bounds[n-1] = 1.0; ++ dlahqr_(&int1, &int1, &n, &int1, &n, workl, &n, ritzr, ritzi, &int1, &int1, bounds, &int1, ierr); ++ ++ if (*ierr != 0) { return; } ++ ++ // 2. Compute the eigenvectors of the full Schur form T and ++ // apply the last components of the Schur vectors to get ++ // the last components of the corresponding eigenvectors. ++ // Remember that if the i-th and (i+1)-st eigenvalues are ++ // complex conjugate pairs, then the real & imaginary part ++ // of the eigenvector components are split across adjacent ++ // columns of Q. ++ ++ dtrevc_("R", "A", select, &n, workl, &n, vl, &n, q, &ldq, &n, &n, &workl[n*n], ierr); ++ if (*ierr != 0) { return; } ++ ++ // Scale the returning eigenvectors so that their ++ // euclidean norms are all one. LAPACK subroutine ++ // dtrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1; here the magnitude of a complex ++ // number (x,y) is taken to be |x| + |y|. ++ ++ iconj = 0; ++ for (i = 0; i < n; i++) ++ { ++ if (fabs(ritzi[i]) == 0.0) ++ { ++ ++ // Real eigenvalue case ++ ++ temp = dnrm2_(&n, &q[ldq*i], &int1); ++ tmp_dbl = 1.0 / temp; ++ dscal_(&n, &tmp_dbl, &q[ldq*i], &int1); ++ ++ } else { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ // columns, we further normalize by the ++ // square root of two. ++ ++ if (iconj == 0) ++ { ++ temp = hypot(dnrm2_(&n, &q[ldq*i], &int1), ++ dnrm2_(&n, &q[ldq*(i+1)], &int1)); ++ tmp_dbl = 1.0 / temp; ++ dscal_(&n, &tmp_dbl, &q[ldq*i], &int1); ++ dscal_(&n, &tmp_dbl, &q[ldq*(i+1)], &int1); ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 10 ++ ++ dgemv_("T", &n, &n, &dbl1, q, &ldq, bounds, &int1, &dbl0, workl, &int1); ++ ++ // Compute the Ritz estimates ++ ++ iconj = 0; ++ for (i = 0; i < n; i++) ++ { ++ if (fabs(ritzi[i]) == 0.0) ++ { ++ ++ // Real eigenvalue case ++ ++ bounds[i] = *rnorm * fabs(workl[i]); ++ ++ } else { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ // columns, we need to take the magnitude ++ // of the last components of the two vectors ++ ++ if (iconj == 0) ++ { ++ bounds[i] = *rnorm * hypot(workl[i], workl[i+1]); ++ bounds[i+1] = bounds[i]; ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 20 ++ ++ return; ++} ++ ++void ++dnaitr(struct ARPACK_arnoldi_update_vars_d *V, int k, int np, double* resid, double* rnorm, ++ double* v, int ldv, double* h, int ldh, int* ipntr, double* workd) ++{ ++ int i = 0, infol, ipj, irj, ivj, jj, n, tmp_int; ++ double smlnum = unfl * ( V->n / ulp); ++ const double sq2o2 = sqrt(2.0) / 2.0; ++ ++ int int1 = 1; ++ double dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0, temp1, tst1; ++ ++ n = V->n; // n is constant, this is just for typing convenience ++ ipj = 0; ++ irj = ipj + n; ++ ivj = irj + n; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // Initial call to this routine ++ ++ V->aitr_j = k; ++ V->info = 0; ++ V->aitr_step3 = 0; ++ V->aitr_step4 = 0; ++ V->aitr_orth1 = 0; ++ V->aitr_orth2 = 0; ++ V->aitr_restart = 0; ++ } ++ ++ // When in reverse communication mode one of: ++ // STEP3, STEP4, ORTH1, ORTH2, RSTART ++ // will be .true. when .... ++ // STEP3: return from computing OP*v_{j}. ++ // STEP4: return from computing B-norm of OP*v_{j} ++ // ORTH1: return from computing B-norm of r_{j+1} ++ // ORTH2: return from computing B-norm of correction to the residual vector. ++ // RSTART: return from OP computations needed by dgetv0. ++ ++ if (V->aitr_step3) { goto LINE50; } ++ if (V->aitr_step4) { goto LINE60; } ++ if (V->aitr_orth1) { goto LINE70; } ++ if (V->aitr_orth2) { goto LINE90; } ++ if (V->aitr_restart) { goto LINE30; } ++ ++ // Else this is the first step ++ ++ // ++ // A R N O L D I I T E R A T I O N L O O P ++ // ++ // Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) ++ ++LINE1000: ++ ++ // STEP 1: Check if the B norm of j-th residual ++ // vector is zero. Equivalent to determining whether ++ // an exact j-step Arnoldi factorization is present. ++ ++ V->aitr_betaj = *rnorm; ++ ++ if (*rnorm > 0.0) { goto LINE40; } ++ ++ // Invariant subspace found, generate a new starting ++ // vector which is orthogonal to the current Arnoldi ++ // basis and continue the iteration. ++ ++ V->aitr_betaj = 0.0; ++ V->getv0_itry = 1; ++ ++LINE20: ++ V->aitr_restart = 1; ++ V->ido = ido_FIRST; ++ ++LINE30: ++ ++ // If in reverse communication mode and aitr_restart = 1, flow returns here. ++ ++ dgetv0(V, 0, n, V->aitr_j, v, ldv, resid, rnorm, ipntr, workd); ++ ++ if (V->ido != ido_DONE) { return; } ++ V->aitr_ierr = V->info; ++ if (V->aitr_ierr < 0) ++ { ++ V->getv0_itry += 1; ++ if (V->getv0_itry <= 3) { goto LINE20; } ++ ++ // Give up after several restart attempts. ++ // Set INFO to the size of the invariant subspace ++ // which spans OP and exit. ++ ++ V->info = V->aitr_j; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++LINE40: ++ ++ // STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm ++ // Note that p_{j} = B*r_{j-1}. In order to avoid overflow ++ // when reciprocating a small RNORM, test against lower ++ // machine bound. ++ ++ dcopy_(&n, resid, &int1, &v[ldv*(V->aitr_j)], &int1); ++ if (*rnorm >= unfl) ++ { ++ temp1 = 1.0 / *rnorm; ++ dscal_(&n, &temp1, &v[ldv*(V->aitr_j)], &int1); ++ dscal_(&n, &temp1, &workd[ipj], &int1); ++ } else { ++ dlascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &v[ldv*(V->aitr_j)], &n, &infol); ++ dlascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &workd[ipj], &n, &infol); ++ } ++ ++ // STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} ++ // Note that this is not quite yet r_{j}. See STEP 4 ++ ++ V->aitr_step3 = 1; ++ dcopy_(&n, &v[ldv*(V->aitr_j)], &int1, &workd[ivj], &int1); ++ ipntr[0] = ivj; ++ ipntr[1] = irj; ++ ipntr[2] = ipj; ++ V->ido = ido_OPX; ++ ++ // Exit in order to compute OP*v_{j} ++ ++ return; ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // WORKD(IRJ:IRJ+N-1) := OP*v_{j} ++ // if step3 = .true. ++ ++ V->aitr_step3 = 0; ++ ++ // Put another copy of OP*v_{j} into RESID. ++ ++ dcopy_(&n, &workd[irj], &int1, resid, &int1); ++ ++ // STEP 4: Finish extending the Arnoldi ++ // factorization to length j. ++ ++ if (V->bmat) ++ { ++ V->aitr_step4 = 1; ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*OP*v_{j} ++ ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE60: ++ ++ // Back from reverse communication; ++ // WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} ++ // if step4 = .true. ++ ++ V->aitr_step4 = 0; ++ ++ // The following is needed for STEP 5. ++ // Compute the B-norm of OP*v_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_wnorm = ddot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_wnorm = sqrt(fabs(V->aitr_wnorm)); ++ } else { ++ V->aitr_wnorm = dnrm2_(&n, resid, &int1); ++ } ++ ++ // Compute the j-th residual corresponding ++ // to the j step factorization. ++ // Use Classical Gram Schmidt and compute: ++ // w_{j} <- V_{j}^T * B * OP * v_{j} ++ // r_{j} <- OP*v_{j} - V_{j} * w_{j} ++ ++ // Compute the j Fourier coefficients w_{j} ++ // WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. ++ tmp_int = V->aitr_j + 1; ++ dgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &h[ldh*(V->aitr_j)], &int1); ++ ++ // Orthogonalize r_{j} against V_{j}. ++ // RESID contains OP*v_{j}. See STEP 3. ++ ++ dgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &h[ldh*(V->aitr_j)], &int1, &dbl1, resid, &int1); ++ ++ if (V->aitr_j > 0) { h[V->aitr_j + ldh*(V->aitr_j-1)] = V->aitr_betaj; } ++ ++ V->aitr_orth1 = 1; ++ if (V->bmat) ++ { ++ dcopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j} ++ ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE70: ++ ++ // Back from reverse communication if ORTH1 = .true. ++ // WORKD(IPJ:IPJ+N-1) := B*r_{j}. ++ ++ V->aitr_orth1 = 0; ++ ++ // Compute the B-norm of r_{j}. ++ ++ if (V->bmat) ++ { ++ *rnorm = ddot_(&n, resid, &int1, &workd[ipj], &int1); ++ *rnorm = sqrt(fabs(*rnorm)); ++ } else { ++ *rnorm = dnrm2_(&n, resid, &int1); ++ } ++ ++ // STEP 5: Re-orthogonalization / Iterative refinement phase ++ // Maximum NITER_ITREF tries. ++ // ++ // s = V_{j}^T * B * r_{j} ++ // r_{j} = r_{j} - V_{j}*s ++ // alphaj = alphaj + s_{j} ++ // ++ // The stopping criteria used for iterative refinement is ++ // discussed in Parlett's book SEP, page 107 and in Gragg & ++ // Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. ++ // Determine if we need to correct the residual. The goal is ++ // to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || ++ // The following test determines whether the sine of the ++ // angle between OP*x and the computed residual is less ++ // than or equal to 0.7071. ++ ++ if (*rnorm > sq2o2*V->aitr_wnorm) { goto LINE100; } ++ V->aitr_iter = 0; ++ ++ // Enter the Iterative refinement phase. If further ++ // refinement is necessary, loop back here. The loop ++ // variable is ITER. Perform a step of Classical ++ // Gram-Schmidt using all the Arnoldi vectors V_{j} ++ ++LINE80: ++ ++ // Compute V_{j}^T * B * r_{j}. ++ // WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). ++ tmp_int = V->aitr_j + 1; ++ dgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &workd[irj], &int1); ++ ++ // Compute the correction to the residual: ++ // r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). ++ // The correction to H is v(:,1:J)*H(1:J,1:J) ++ // + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. ++ ++ dgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &workd[irj], &int1, &dbl1, resid, &int1); ++ daxpy_(&tmp_int, &dbl1, &workd[irj], &int1, &h[ldh*(V->aitr_j)], &int1); ++ ++ V->aitr_orth2 = 1; ++ ++ if (V->bmat) ++ { ++ dcopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j}. ++ // r_{j} is the corrected residual. ++ ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE90: ++ ++ // Back from reverse communication if ORTH2 = .true. ++ ++ // Compute the B-norm of the corrected residual r_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_rnorm1 = ddot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_rnorm1 = sqrt(fabs(V->aitr_rnorm1)); ++ } else { ++ V->aitr_rnorm1 = dnrm2_(&n, resid, &int1); ++ } ++ ++ // Determine if we need to perform another ++ // step of re-orthogonalization. ++ ++ if (V->aitr_rnorm1 > sq2o2*(*rnorm)) ++ { ++ ++ // No need for further refinement. ++ // The cosine of the angle between the ++ // corrected residual vector and the old ++ // residual vector is greater than 0.717 ++ // In other words the corrected residual ++ // and the old residual vector share an ++ // angle of less than arcCOS(0.717) ++ ++ *rnorm = V->aitr_rnorm1; ++ ++ } else { ++ ++ // Another step of iterative refinement step ++ // is required. ++ ++ *rnorm = V->aitr_rnorm1; ++ V->aitr_iter += 1; ++ if (V->aitr_iter < 2) { goto LINE80; } ++ ++ // Otherwise RESID is numerically in the span of V ++ ++ for (jj = 0; jj < n; jj++) ++ { ++ resid[jj] = 0.0; ++ } ++ *rnorm = 0.0; ++ } ++ ++ // Branch here directly if iterative refinement ++ // wasn't necessary or after at most NITER_REF ++ // steps of iterative refinement. ++ ++LINE100: ++ ++ V->aitr_restart = 0; ++ V->aitr_orth2 = 0; ++ ++ // STEP 6: Update j = j+1; Continue ++ ++ V->aitr_j += 1; ++ if (V->aitr_j >= k + np) ++ { ++ V->ido = ido_DONE; ++ for (i = (k > 0 ? k-1 : k); i < k + np - 1; i++) ++ { ++ ++ // Check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine dlahqr ++ ++ tst1 = fabs(h[i + ldh*i]) + fabs(h[i+1 + ldh*(i+1)]); ++ if (tst1 == 0.0) ++ { ++ tmp_int = k + np; ++ tst1 = dlanhs_("1", &tmp_int, h, &ldh, &workd[n]); ++ } ++ if (fabs(h[i+1 + ldh*i]) <= fmax(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = 0.0; ++ } ++ } ++ // 110 ++ return; ++ } ++ goto LINE1000; ++ ++} ++ ++ ++void ++dnapps(int n, int* kev, int np, double* shiftr, double* shifti, double* v, ++ int ldv, double* h, int ldh, double* resid, double* q, int ldq, double* workl, ++ double* workd) ++{ ++ int cconj; ++ int i, ir, j, jj, int1 = 1, istart, iend = 0, nr, tmp_int; ++ int kplusp = *kev + np; ++ double smlnum = unfl * ( n / ulp); ++ double c, f, g, h11, h21, h12, h22, h32, s, sigmar, sigmai, r, t, tau, tst1; ++ double dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0; ++ double u[3] = { 0.0 }; ++ ++ // Initialize Q to the identity to accumulate ++ // the rotations and reflections ++ dlaset_("A", &kplusp, &kplusp, &dbl0, &dbl1, q, &ldq); ++ ++ // Quick return if there are no shifts to apply ++ ++ if (np == 0) { return; } ++ ++ // Chase the bulge with the application of each ++ // implicit shift. Each shift is applied to the ++ // whole matrix including each block. ++ ++ cconj = 0; ++ ++ // Loop over the shifts ++ ++ for (jj = 0; jj < np; jj++) ++ { ++ sigmar = shiftr[jj]; ++ sigmai = shifti[jj]; ++ ++ if (cconj) ++ { ++ ++ // Skip flag is on; turn it off and proceed to the next shift. ++ ++ cconj = 0; ++ continue; ++ ++ } else if ((jj < np - 1) && fabs(sigmai) != 0.0) { ++ ++ // This shift has nonzero imaginary part, so we will apply ++ // together with the next one; turn on the skip flag. ++ ++ cconj = 1; ++ ++ } else if ((jj == np - 1) && (fabs(sigmai) != 0.0)) { ++ ++ // We have one block left but the shift has nonzero imaginary part. ++ // Don't apply it and reduce the number of shifts by incrementing ++ // kev by one. ++ ++ *kev += 1; ++ continue; ++ } ++ ++ // if sigmai = 0 then ++ // Apply the jj-th shift ... ++ // else ++ // Apply the jj-th and (jj+1)-th together ... ++ // (Note that jj < np at this point in the code) ++ // end ++ // to the current block of H ++ ++ istart = 0; ++ while (istart < kplusp - 1) ++ { ++ for (iend = istart; iend < kplusp - 1; iend++) ++ { ++ tst1 = fabs(h[iend + (iend * ldh)]) + fabs(h[iend + 1 + (iend + 1) * ldh]); ++ if (tst1 == 0.0) ++ { ++ tmp_int = kplusp - jj; ++ tst1 = dlanhs_("1", &tmp_int, h, &ldh, workl); ++ } ++ if (fabs(h[iend+1 + (iend * ldh)]) <= fmax(smlnum, ulp * tst1)) ++ { ++ break; ++ } ++ } ++ if (istart == iend) ++ { ++ istart += 1; ++ continue; ++ } else if ((istart + 1 == iend) && fabs(sigmai) > 0.0) { ++ istart += 2; ++ continue; ++ } else { ++ h[iend+1 + (iend * ldh)] = 0.0; ++ } ++ ++ // We have a block [istart, iend] inclusive. ++ h11 = h[istart + istart * ldh]; ++ h21 = h[istart + 1 + istart * ldh]; ++ ++ if (fabs(sigmai) == 0.0) ++ { ++ ++ f = h11 - sigmar; ++ g = h21; ++ for (i = istart; i < iend; i++) ++ { ++ dlartgp_(&f, &g, &c, &s, &r); ++ if (i > istart) ++ { ++ h[i + (i - 1) * ldh] = r; ++ h[i + 1 + (i - 1) * ldh] = 0.0; ++ } ++ tmp_int = kplusp - i; ++ drot_(&tmp_int, &h[i + ldh*i], &ldh, &h[i + 1 + ldh*i], &ldh, &c, &s); ++ tmp_int = (i+2 > iend ? iend : i + 2) + 1; ++ drot_(&tmp_int, &h[ldh*i], &int1, &h[ldh*(i+1)], &int1, &c, &s); ++ tmp_int = (i+jj+2 > kplusp ? kplusp : i + jj + 2); ++ drot_(&tmp_int, &q[ldq*i], &int1, &q[ldq*(i+1)], &int1, &c, &s); ++ ++ if (i < iend - 1) ++ { ++ f = h[i+1 + i * ldh]; ++ g = h[i+2 + i * ldh]; ++ } ++ } ++ } else { ++ ++ h12 = h[istart + ldh*(istart + 1)]; ++ h22 = h[istart + 1 + ldh*(istart + 1)]; ++ h32 = h[istart + 2 + ldh*(istart + 1)]; ++ ++ s = 2.0*sigmar; ++ t = hypot(sigmar, sigmai); ++ u[0] = (h11*(h11 - s) + t*t) / h21 + h12; ++ u[1] = h11 + h22 - s; ++ u[2] = h32; ++ ++ for (i = istart; i < iend; i++) ++ { ++ nr = iend - i + 1; ++ nr = (nr > 3? 3 : nr); ++ dlarfg_(&nr, &u[0], &u[1], &int1, &tau); ++ if (i > istart) ++ { ++ h[i + (i - 1) * ldh] = u[0]; ++ h[i + 1 + (i - 1) * ldh] = 0.0; ++ if (i < iend - 1) { h[i + 2 + (i - 1) * ldh] = 0.0; } ++ } ++ u[0] = 1.0; ++ ++ tmp_int = kplusp - i; ++ dlarf_("L", &nr, &tmp_int, u, &int1, &tau, &h[i + ldh*i], &ldh, workl); ++ ir = (i + 3 > iend ? iend : i + 3) + 1; ++ dlarf_("R", &ir, &nr, u, &int1, &tau, &h[ldh*i], &ldh, workl); ++ dlarf_("R", &kplusp, &nr, u, &int1, &tau, &q[ldq*i], &ldq, workl); ++ if (i < iend - 1) ++ { ++ u[0] = h[i+1 + i * ldh]; ++ u[1] = h[i+2 + i * ldh]; ++ if (i < iend-2) { u[2] = h[i+3 + i * ldh]; } ++ } ++ } ++ } ++ istart = iend + 1; ++ } ++ } ++ // Perform a similarity transformation that makes ++ // sure that H will have non negative sub diagonals ++ ++ for (j = 0; j < *kev; j++) ++ { ++ if (h[j+1 + ldh*j] < 0.0) ++ { ++ tmp_int = kplusp - j; ++ dscal_(&tmp_int, &dblm1, &h[j+1 + ldh*j], &ldh); ++ tmp_int = (j+3 > kplusp ? kplusp : j+3); ++ dscal_(&tmp_int, &dblm1, &h[ldh*(j+1)], &int1); ++ tmp_int = (j+np+2 > kplusp ? kplusp : j+np+2); ++ dscal_(&tmp_int, &dblm1, &q[ldq*(j+1)], &int1); ++ } ++ } ++ // 120 ++ ++ for (i = 0; i < *kev; i++) ++ { ++ ++ // Final check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine dlahqr ++ ++ tst1 = fabs(h[i + ldh*i]) + fabs(h[i+1 + ldh*(i+1)]); ++ if (tst1 == 0.0) ++ { ++ tst1 = dlanhs_("1", kev, h, &ldh, workl); ++ } ++ if (h[i+1 + ldh*i] <= fmax(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = 0.0; ++ } ++ } ++ // 130 ++ ++ // Compute the (kev+1)-st column of (V*Q) and ++ // temporarily store the result in WORKD(N+1:2*N). ++ // This is needed in the residual update since we ++ // cannot GUARANTEE that the corresponding entry ++ // of H would be zero as in exact arithmetic. ++ ++ if (h[*kev + ldh*(*kev-1)] > 0.0) ++ { ++ dgemv_("N", &n, &kplusp, &dbl1, v, &ldv, &q[(*kev)*ldq], &int1, &dbl0, &workd[n], &int1); ++ } ++ ++ // Compute column 1 to kev of (V*Q) in backward order ++ // taking advantage of the upper Hessenberg structure of Q. ++ ++ for (i = 0; i < *kev; i++) ++ { ++ tmp_int = kplusp - i; ++ dgemv_("N", &n, &tmp_int, &dbl1, v, &ldv, &q[(*kev-i-1)*ldq], &int1, &dbl0, workd, &int1); ++ dcopy_(&n, workd, &int1, &v[(kplusp-i-1)*ldv], &int1); ++ } ++ ++ // Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). ++ ++ for (i = 0; i < *kev; i++) ++ { ++ dcopy_(&n, &v[(kplusp-*kev+i)*ldv], &int1, &v[i*ldv], &int1); ++ } ++ ++ // Copy the (kev+1)-st column of (V*Q) in the appropriate place ++ ++ if (h[*kev + ldh*(*kev-1)] > 0.0){ ++ dcopy_(&n, &workd[n], &int1, &v[ldv*(*kev)], &int1); ++ } ++ ++ // Update the residual vector: ++ // r <- sigmak*r + betak*v(:,kev+1) ++ // where ++ // sigmak = (e_{kplusp}'*Q)*e_{kev} ++ // betak = e_{kev+1}'*H*e_{kev} ++ ++ dscal_(&n, &q[kplusp-1 + ldq*(*kev-1)], resid, &int1); ++ ++ if (h[*kev + ldh*(*kev-1)] > 0.0) ++ { ++ daxpy_(&n, &h[*kev + ldh*(*kev-1)], &v[ldv*(*kev)], &int1, resid, &int1); ++ } ++ ++ return; ++ ++} ++ ++ ++void ++dngets(struct ARPACK_arnoldi_update_vars_d *V, int* kev, int* np, ++ double* ritzr, double* ritzi, double* bounds) ++{ ++ ++ // LM, SM, LR, SR, LI, SI case. ++ // Sort the eigenvalues of H into the desired order ++ // and apply the resulting order to BOUNDS. ++ // The eigenvalues are sorted so that the wanted part ++ // are always in the last KEV locations. ++ // We first do a pre-processing sort in order to keep ++ // complex conjugate pairs together ++ ++ switch (V->which) ++ { ++ case which_LM: ++ dsortc(which_LR, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_SM: ++ dsortc(which_SR, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_LR: ++ dsortc(which_LM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_SR: ++ dsortc(which_SM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_LI: ++ dsortc(which_LM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_SI: ++ dsortc(which_SM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ default: ++ dsortc(which_LR, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ } ++ dsortc(V->which, 1, *kev + *np, ritzr, ritzi, bounds); ++ ++ // Increase KEV by one if the ( ritzr(np),ritzi(np) ) ++ // = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero ++ // Accordingly decrease NP by one. In other words keep ++ // complex conjugate pairs together. ++ ++ if ((ritzr[*np] - ritzr[*np-1] == 0.0) && (ritzi[*np] + ritzi[*np-1] == 0.0)) ++ { ++ *np -= 1; ++ *kev += 1; ++ } ++ ++ if (V->shift == 1) ++ { ++ ++ // Sort the unwanted Ritz values used as shifts so that ++ // the ones with largest Ritz estimates are first ++ // This will tend to minimize the effects of the ++ // forward instability of the iteration when they shifts ++ // are applied in subroutine dnapps. ++ // Be careful and use 'SR' since we want to sort BOUNDS! ++ ++ dsortc(which_SR, 1, *np, bounds, ritzr, ritzi); ++ } ++ ++ return; ++} ++ ++void ++dgetv0(struct ARPACK_arnoldi_update_vars_d *V, int initv, int n, int j, ++ double* v, int ldv, double* resid, double* rnorm, int* ipntr, double* workd) ++{ ++ int jj, int1 = 1; ++ const double sq2o2 = sqrt(2.0) / 2.0; ++ double dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->info = 0; ++ V->getv0_iter = 0; ++ V->getv0_first = 0; ++ V->getv0_orth = 0; ++ ++ // Possibly generate a random starting vector in RESID ++ // Skip if this the return of ido_RANDOM. ++ ++ if (!(initv)) ++ { ++ // Request a random vector from the user into resid ++ V->ido = ido_RANDOM; ++ return; ++ } else { ++ V->ido = ido_RANDOM; ++ } ++ } ++ ++ // Back from random vector generation ++ if (V->ido == ido_RANDOM) ++ { ++ // Force the starting vector into the range of OP to handle ++ // the generalized problem when B is possibly (singular). ++ ++ if (V->getv0_itry == 1) ++ { ++ ipntr[0] = 0; ++ ipntr[1] = n; ++ dcopy_(&n, resid, &int1, workd, &int1); ++ V->ido = ido_RANDOM_OPX; ++ return; ++ } else if ((V->getv0_itry > 1) && (V->bmat == 1)) ++ { ++ dcopy_(&n, resid, &int1, &workd[n], &int1); ++ } ++ } ++ ++ // Back from computing OP*(initial-vector) ++ ++ if (V->getv0_first) { goto LINE20; } ++ ++ // Back from computing OP*(orthogonalized-vector) ++ ++ if (V->getv0_orth) { goto LINE40; } ++ ++ // Starting vector is now in the range of OP; r = OP*r; ++ // Compute B-norm of starting vector. ++ ++ V->getv0_first = 1; ++ if (V->getv0_itry == 1) ++ { ++ dcopy_(&n, &workd[n], &int1, resid, &int1); ++ } ++ if (V->bmat) ++ { ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE20: ++ ++ V->getv0_first = 0; ++ if (V->bmat) ++ { ++ V->getv0_rnorm0 = ddot_(&n, resid, &int1, workd, &int1); ++ V->getv0_rnorm0 = sqrt(fabs(V->getv0_rnorm0)); ++ } else { ++ V->getv0_rnorm0 = dnrm2_(&n, resid, &int1); ++ } ++ *rnorm = V->getv0_rnorm0; ++ ++ // Exit if this is the very first Arnoldi step ++ ++ if (j == 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Otherwise need to B-orthogonalize the starting vector against ++ // the current Arnoldi basis using Gram-Schmidt with iter. ref. ++ // This is the case where an invariant subspace is encountered ++ // in the middle of the Arnoldi factorization. ++ // ++ // s = V^{T}*B*r; r = r - V*s; ++ // ++ // Stopping criteria used for iter. ref. is discussed in ++ // Parlett's book, page 107 and in Gragg & Reichel TOMS paper. ++ ++ V->getv0_orth = 1; ++ ++LINE30: ++ ++ dgemv_("T", &n, &j, &dbl1, v, &ldv, workd, &int1, &dbl0, &workd[n], &int1); ++ dgemv_("N", &n, &j, &dblm1, v, &ldv, &workd[n], &int1, &dbl1, resid, &int1); ++ ++ // Compute the B-norm of the orthogonalized starting vector ++ ++ if (V->bmat) ++ { ++ dcopy_(&n, resid, &int1, &workd[n], &int1); ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE40: ++ if (V->bmat) ++ { ++ *rnorm = ddot_(&n, resid, &int1, workd, &int1); ++ *rnorm = sqrt(fabs(*rnorm)); ++ } else { ++ *rnorm = dnrm2_(&n, resid, &int1); ++ } ++ ++ // Check for further orthogonalization. ++ ++ if (*rnorm > sq2o2*V->getv0_rnorm0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->getv0_iter += 1; ++ if (V->getv0_iter < 5) ++ { ++ ++ // Perform iterative refinement step ++ ++ V->getv0_rnorm0 = *rnorm; ++ goto LINE30; ++ } else { ++ ++ // Iterative refinement step "failed" ++ ++ for (jj = 0; jj < n; jj++) { resid[jj] = 0.0; } ++ *rnorm = 0.0; ++ V->info = -1; ++ } ++ ++ V->ido = ido_DONE; ++ ++ return; ++} ++ ++void ++dsortc(const enum ARPACK_which w, const int apply, const int n, double* xreal, double* ximag, double* y) ++{ ++ int i, igap, j; ++ double temp; ++ ARPACK_compare_cfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortc_LM; ++ break; ++ case which_SM: ++ f = sortc_SM; ++ break; ++ case which_LR: ++ f = sortc_LR; ++ break; ++ case which_LI: ++ f = sortc_LI; ++ break; ++ case which_SR: ++ f = sortc_SR; ++ break; ++ case which_SI: ++ f = sortc_SI; ++ break; ++ default: ++ f = sortc_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(xreal[j], ximag[j], xreal[j+igap], ximag[j+igap])) ++ { ++ if (j < 0) { break; } ++ temp = xreal[j]; ++ xreal[j] = xreal[j+igap]; ++ xreal[j+igap] = temp; ++ temp = ximag[j]; ++ ximag[j] = ximag[j+igap]; ++ ximag[j+igap] = temp; ++ ++ if (apply) ++ { ++ temp = y[j]; ++ y[j] = y[j+igap]; ++ y[j+igap] = temp; ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++} ++ ++// The void casts are to avoid compiler warnings for unused parameters ++int ++sortc_LM(const double xre, const double xim, const double xreigap, const double ximigap) ++{ ++ return (hypot(xre, xim) > hypot(xreigap, ximigap)); ++} ++ ++int ++sortc_SM(const double xre, const double xim, const double xreigap, const double ximigap) ++{ ++ return (hypot(xre, xim) < hypot(xreigap, ximigap)); ++} ++ ++int ++sortc_LR(const double xre, const double xim, const double xreigap, const double ximigap) ++{ ++ (void)xim; (void)ximigap; ++ return (xre > xreigap); ++} ++ ++int ++sortc_SR(const double xre, const double xim, const double xreigap, const double ximigap) ++{ ++ (void)xim; (void)ximigap; ++ return (xre < xreigap); ++} ++ ++int ++sortc_LI(const double xre, const double xim, const double xreigap, const double ximigap) ++{ ++ (void)xre; (void)xreigap; ++ return (fabs(xim) > fabs(ximigap)); ++} ++ ++int ++sortc_SI(const double xre, const double xim, const double xreigap, const double ximigap) ++{ ++ (void)xre; (void)xreigap; ++ return (fabs(xim) < fabs(ximigap)); ++} +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.h +new file mode 100644 +index 0000000000..e22bec06a6 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double.h +@@ -0,0 +1,32 @@ ++#ifndef _ARPACK_N_DOUBLE_H ++#define _ARPACK_N_DOUBLE_H ++ ++#include "_arpack.h" ++ ++// BLAS Routines used ++void daxpy_(int* n, double* alpha, double* x, int* incx, double* y, int* incy); ++void dcopy_(int* n, double* x, int* incx, double* y, int* incy); ++double ddot_(int* n, double* x, int* incx, double* y, int* incy); ++void dger_(int* m, int* n, double* alpha, double* x, int* incx, double* y, int* incy, double* a, int* lda); ++double dnrm2_(int* n, double* x, int* incx); ++void dscal_(int* n, double* alpha, double* x, int* incx); ++void dgemv_(char* trans, int* m, int* n, double* alpha, double* a, int* lda, double* x, int* incx, double* beta, double* y, int* incy); ++void drot_(int* n, double* x, int* incx, double* y, int* incy, double* c, double* s); ++void dtrmm_(char* side, char* uplo, char* transa, char* diag, int* m, int* n, double* alpha, double* a, int* lda, double* b, int* ldb); ++ ++// LAPACK Routines used ++void dgeqr2_(int* m, int* n, double* a, int* lda, double* tau, double* work, int* info); ++void dlacpy_(char* uplo, int* m, int* n, double* a, int* lda, double* b, int* ldb); ++void dlahqr_(int* wantt, int* wantz, int* n, int* ilo, int* ihi, double* h, int* ldh, double* wr, double* wi, int* iloz, int* ihiz, double* z, int* ldz, int* info ); ++double dlanhs_(char* norm, int* n, double* a, int* lda, double* work); ++void dlaset_(char* uplo, int* m, int* n, double* alpha, double* beta, double* a, int* lda); ++void dlarf_(char* side, int* m, int* n, double* v, int* incv, double* tau, double* c, int* ldc, double* work); ++void dlarfg_(int* n, double* alpha, double* x, int* incx, double* tau); ++void dlartg_(double* f, double* g, double* c, double* s, double* r); ++void dlartgp_(double* f, double* g, double* c, double* s, double* r); ++void dlascl_(char* mtype, int* kl, int* ku, double* cfrom, double* cto, int* m, int* n, double* a, int* lda, int* info); ++void dorm2r_(char* side, char* trans, int* m, int* n, int* k, double* a, int* lda, double* tau, double* c, int* ldc, double* work, int* info); ++void dtrevc_(char* side, char* howmny, int* select, int* n, double* t, int* ldt, double* vl, int* ldvl, double* vr, int* ldvr, int* mm, int* m, double* work, int* info); ++void dtrsen_(char* job, char* compq, int* select, int* n, double* t, int* ldt, double* q, int* ldq, double* wr, double* wi, int* m, double* s, double* sep, double* work, int* lwork, int* iwork, int* liwork, int* info); ++ ++#endif +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.c b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.c +new file mode 100644 +index 0000000000..ff85aa3417 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.c +@@ -0,0 +1,1861 @@ ++#include "_arpack_n_double_complex.h" ++ ++typedef int ARPACK_compare_cfunc(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++typedef int ARPACK_compare_rfunc(const double, const double); ++ ++static const double unfl = 2.2250738585072014e-308; ++// static const double ovfl = 1.0 / 2.2250738585072014e-308; ++static const double ulp = 2.220446049250313e-16; ++ ++static ARPACK_CPLX_TYPE zdotc_(const int* n, const ARPACK_CPLX_TYPE* restrict x, const int* incx, const ARPACK_CPLX_TYPE* restrict y, const int* incy); ++static void zgetv0(struct ARPACK_arnoldi_update_vars_d*, int, int, int, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, double*, int*, ARPACK_CPLX_TYPE*); ++static void znaup2(struct ARPACK_arnoldi_update_vars_d*, ARPACK_CPLX_TYPE* , ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, int*, ARPACK_CPLX_TYPE*, double*); ++static void znaitr(struct ARPACK_arnoldi_update_vars_d*, int, int, ARPACK_CPLX_TYPE*, double*, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, int, int*, ARPACK_CPLX_TYPE*); ++static void znapps(int, int*, int, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*); ++static void zneigh(double*, int, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*, int, ARPACK_CPLX_TYPE*, double*, int*); ++static void zngets(struct ARPACK_arnoldi_update_vars_d*, int*, int*, ARPACK_CPLX_TYPE*, ARPACK_CPLX_TYPE*); ++static void zsortc(const enum ARPACK_which w, const int apply, const int n, ARPACK_CPLX_TYPE* x, ARPACK_CPLX_TYPE* y); ++static int sortc_LM(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++static int sortc_SM(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++static int sortc_LR(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++static int sortc_SR(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++static int sortc_LI(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++static int sortc_SI(const ARPACK_CPLX_TYPE, const ARPACK_CPLX_TYPE); ++ ++enum ARPACK_neupd_type { ++ REGULAR, ++ SHIFTI, ++ REALPART, ++ IMAGPART ++}; ++ ++ ++void ++ARPACK_zneupd(struct ARPACK_arnoldi_update_vars_d *V, int rvec, int howmny, int* select, ++ ARPACK_CPLX_TYPE* d, ARPACK_CPLX_TYPE* z, int ldz, ARPACK_CPLX_TYPE sigma, ++ ARPACK_CPLX_TYPE* workev, ARPACK_CPLX_TYPE* resid, ARPACK_CPLX_TYPE* v, int ldv, ++ int* ipntr, ARPACK_CPLX_TYPE* workd, ARPACK_CPLX_TYPE* workl, double* rwork) ++{ ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ int ibd, ih, iheig, ihbds, iuptri, invsub, irz, iwev, j, jj; ++ int bounds, k, ldh, ldq, np, numcnv, outncv, reord, ritz, wr; ++ int ierr = 0, int1 = 1, tmp_int = 0, nconv2 = 0; ++ double conds, sep, temp1, rtemp; ++ ARPACK_CPLX_TYPE rnorm, temp; ++ ARPACK_CPLX_TYPE cdbl0 = ARPACK_cplx(0.0, 0.0); ++ ARPACK_CPLX_TYPE cdbl1 = ARPACK_cplx(1.0, 0.0); ++ ARPACK_CPLX_TYPE cdblm1 = ARPACK_cplx(-1.0, 0.0); ++ ARPACK_CPLX_TYPE vl[1] = { cdbl0 }; ++ enum ARPACK_neupd_type TYP; ++ ++ if (V->nconv <= 0) { ++ ierr = -14; ++ } else if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv <= V->nev + 1) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if ((V->which > 5) || (V->which < 0)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((rvec) && ((howmny < 0) || (howmny > 2))) { ++ ierr = -13; ++ } else if (howmny == 2) { ++ ierr = -12; // NotImplementedError ++ } ++ ++ if ((V->mode == 1) || (V->mode == 2)) { ++ TYP = REGULAR; ++ } else if (V->mode == 3) { ++ TYP = SHIFTI; ++ } else { ++ ierr = -10; ++ } ++ ++ if ((V->mode == 1) && (V->bmat)) { ierr = -11; } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ return; ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, WORKEV, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:ncv*ncv) := generated Hessenberg matrix ++ // workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values ++ // workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds ++ ++ // The following is used and set by ZNEUPD. ++ // workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed ++ // Ritz values. ++ // workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed ++ // error bounds of ++ // the Ritz values ++ // workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper ++ // triangular matrix ++ // for H. ++ // workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the ++ // associated matrix ++ // representation of ++ // the invariant ++ // subspace for H. ++ // GRAND total of NCV * ( 3 * NCV + 4 ) locations. ++ ++ ih = ipntr[4]; ++ ritz = ipntr[5]; ++ bounds = ipntr[7]; ++ ldh = V->ncv; ++ ldq = V->ncv; ++ iheig = bounds + ldh; ++ ihbds = iheig + ldh; ++ iuptri = ihbds + ldh; ++ invsub = iuptri + ldh*V->ncv; ++ ipntr[8] = iheig; ++ ipntr[10] = ihbds; ++ ipntr[11] = iuptri; ++ ipntr[12] = invsub; ++ wr = 0; ++ iwev = wr + V->ncv; ++ ++ // irz points to the Ritz values computed ++ // by _neigh before exiting _naup2. ++ // ibd points to the Ritz estimates ++ // computed by _neigh before exiting ++ // _naup2. ++ ++ irz = ipntr[13] + (V->ncv)*(V->ncv); ++ ibd = irz + V->ncv; ++ ++ // RNORM is B-norm of the RESID(1:N). ++ ++ rnorm = workl[ih+2]; ++ workl[ih+2] = ARPACK_cplx(0.0, 0.0); ++ ++ if (rvec) { ++ reord = 0; ++ ++ // Use the temporary bounds array to store indices ++ // These will be used to mark the select array later ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[bounds + j] = ARPACK_cplx(j, 0.0); ++ select[j] = 0; ++ } ++ // 10 ++ ++ // Select the wanted Ritz values. ++ // Sort the Ritz values so that the ++ // wanted ones appear at the tailing ++ // NEV positions of workl(irr) and ++ // workl(iri). Move the corresponding ++ // error estimates in workl(ibd) ++ // accordingly. ++ ++ np = V->ncv - V->nev; ++ zngets(V, &V->nev, &np, &workl[irz], &workl[bounds]); ++ ++ // Record indices of the converged wanted Ritz values ++ // Mark the select array for possible reordering ++ ++ numcnv = 0; ++ for (j = 1; j <= V->ncv; j++) ++ { ++ temp1 = fmax(eps23, cabs(workl[irz + V->ncv - j])); ++ jj = (int)creal(workl[bounds + V->ncv - j]); ++ ++ if ((numcnv < V->nconv) && (cabs(workl[ibd + jj]) <= V->tol*temp1)) ++ { ++ select[jj] = 1; ++ numcnv += 1; ++ if (jj > V->nconv - 1) { reord = 1; } ++ } ++ } ++ // 11 ++ ++ // Check the count (numcnv) of converged Ritz values with ++ // the number (nconv) reported by znaupd. If these two ++ // are different then there has probably been an error ++ // caused by incorrect passing of the znaupd data. ++ ++ if (numcnv != V->nconv) ++ { ++ V->info = -15; ++ return; ++ } ++ ++ // Call LAPACK routine zlahqr to compute the Schur form ++ // of the upper Hessenberg matrix returned by ZNAUPD . ++ // Make a copy of the upper Hessenberg matrix. ++ // Initialize the Schur vector matrix Q to the identity. ++ ++ tmp_int = ldh*V->ncv; ++ zcopy_(&tmp_int, &workl[ih], &int1, &workl[iuptri], &int1); ++ zlaset_("A", &V->ncv, &V->ncv, &cdbl0, &cdbl1, &workl[invsub], &ldq); ++ zlahqr_(&int1, &int1, &V->ncv, &int1, &V->ncv, &workl[iuptri], &ldh, ++ &workl[iheig], &int1, &V->ncv, &workl[invsub], &ldq, &ierr); ++ zcopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ if (ierr != 0) ++ { ++ V->info = -8; ++ return; ++ } ++ ++ if (reord) ++ { ++ ++ // Reorder the computed upper triangular matrix. ++ ++ ztrsen_("N", "V", select, &V->ncv, &workl[iuptri], &ldh, &workl[invsub], &ldq, ++ &workl[iheig], &nconv2, &conds, &sep, workev, &V->ncv, &ierr); ++ ++ if (nconv2 < V->nconv) { V->nconv = nconv2; } ++ if (ierr == 1) { ++ V->info = 1; ++ return; ++ } ++ } ++ ++ // Copy the last row of the Schur basis matrix ++ // to workl(ihbds). This vector will be used ++ // to compute the Ritz estimates of converged ++ // Ritz values. ++ ++ zcopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ // Place the computed eigenvalues of H into D ++ // if a spectral transformation was not used. ++ ++ if (TYP == REGULAR) ++ { ++ zcopy_(&V->nconv, &workl[iheig], &int1, d, &int1); ++ } ++ ++ // Compute the QR factorization of the matrix representing ++ // the wanted invariant subspace located in the first NCONV ++ // columns of workl(invsub,ldq). ++ ++ zgeqr2_(&V->ncv, &V->nconv, &workl[invsub], &ldq, workev, &workev[V->ncv], &ierr); ++ ++ // * Postmultiply V by Q using zunm2r. ++ // * Copy the first NCONV columns of VQ into Z. ++ // * Postmultiply Z by R. ++ // The N by NCONV matrix Z is now a matrix representation ++ // of the approximate invariant subspace associated with ++ // the Ritz values in workl(iheig). The first NCONV ++ // columns of V are now approximate Schur vectors ++ // associated with the upper triangular matrix of order ++ // NCONV in workl(iuptri). ++ ++ zunm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[invsub], &ldq, workev, v, &ldv, &workd[V->n], &ierr); ++ zlacpy_("A", &V->n, &V->nconv, v, &ldv, z, &ldz); ++ ++ for (int j = 0; j < V->nconv; j++) ++ { ++ ++ // Perform both a column and row scaling if the ++ // diagonal element of workl(invsub,ldq) is negative ++ // I'm lazy and don't take advantage of the upper ++ // triangular form of workl(iuptri,ldq). ++ // Note that since Q is orthogonal, R is a diagonal ++ // matrix consisting of plus or minus ones. ++ ++ if (creal(workl[invsub + j*ldq + j]) < 0.0) ++ { ++ zscal_(&V->nconv, &cdblm1, &workl[iuptri + j], &ldq); ++ zscal_(&V->nconv, &cdblm1, &workl[iuptri + j*ldq], &int1); ++ } ++ } ++ // 20 ++ ++ if (howmny == 0) ++ { ++ ++ // Compute the NCONV wanted eigenvectors of T ++ // located in workl(iuptri,ldq). ++ ++ for (int j = 0; j < V->ncv; j++) ++ { ++ if (j < V->nconv) ++ { ++ select[j] = 1; ++ } else { ++ select[j] = 0; ++ } ++ } ++ // 30 ++ ++ ztrevc_("R", "S", select, &V->ncv, &workl[iuptri], &ldq, vl, &int1, ++ &workl[invsub], &ldq, &V->ncv, &outncv, workev, rwork, &ierr); ++ if (ierr != 0) ++ { ++ V->info = -9; ++ return; ++ } ++ ++ // Scale the returning eigenvectors so that their ++ // Euclidean norms are all one. LAPACK subroutine ++ // ztrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1. ++ ++ for (j = 0; j < V->nconv; j++) ++ { ++ rtemp = 1.0 / dznrm2_(&V->ncv, &workl[invsub + j*ldq], &int1); ++ zdscal_(&V->ncv, &rtemp, &workl[invsub + j*ldq], &int1); ++ ++ // Ritz estimates can be obtained by taking ++ // the inner product of the last row of the ++ // Schur basis of H with eigenvectors of T. ++ // Note that the eigenvector matrix of T is ++ // upper triangular, thus the length of the ++ // inner product can be set to j. ++ tmp_int = j + 1; ++ workev[j] = zdotc_(&tmp_int, &workl[ihbds], &int1, &workl[invsub + j*ldq], &int1); ++ } ++ // 40 ++ ++ // Copy Ritz estimates into workl(ihbds) ++ ++ zcopy_(&V->nconv, workev, &int1, &workl[ihbds], &int1); ++ ++ // The eigenvector mactirx Q of T is triangular. Form Z*Q ++ ++ ztrmm_("R", "U", "N", "N", &V->n, &V->nconv, &cdbl1, &workl[invsub], &ldq, z, &ldz); ++ ++ } ++ ++ } else { ++ ++ // An approximate invariant subspace is not needed. ++ // Place the Ritz values computed ZNAUPD into D. ++ ++ zcopy_(&V->nconv, &workl[ritz], &int1, d, &int1); ++ zcopy_(&V->nconv, &workl[ritz], &int1, &workl[iheig], &int1); ++ zcopy_(&V->nconv, &workl[bounds], &int1, &workl[ihbds], &int1); ++ ++ } ++ ++ // Transform the Ritz values and possibly vectors ++ // and corresponding error bounds of OP to those ++ // of A*x = lambda*B*x. ++ ++ if (TYP == REGULAR) ++ { ++ if (rvec) ++ { ++ zscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ } else { ++ ++ // A spectral transformation was used. ++ // * Determine the Ritz estimates of the ++ // Ritz values in the original system. ++ ++ if (rvec) ++ { ++ zscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ for (k = 0; k < V->ncv; k++) ++ { ++#if defined(_MSC_VER) ++ // Complex division is not supported in MSVC, multiply with reciprocal ++ temp = _Cmulcr(conj(workl[iheig + k]), 1.0 / cabs(workl[iheig + k])); ++ workl[ihbds + k] = _Cmulcc(_Cmulcc(workl[ihbds + k], temp), temp); ++#else ++ temp = workl[iheig + k]; ++ workl[ihbds + k] = workl[ihbds + k] / temp / temp; ++#endif ++ } ++ // 50 ++ } ++ ++ // * Transform the Ritz values back to the original system. ++ // For TYPE = 'SHIFTI' the transformation is ++ // lambda = 1/theta + sigma ++ // NOTES: ++ // *The Ritz vectors are not affected by the transformation. ++ ++ if (TYP == SHIFTI) ++ { ++ for (k = 0; k < V->nconv; k++) ++ { ++#if defined(_MSC_VER) ++ // Complex division is not supported in MSVC ++ temp = _Cmulcr(conj(workl[iheig + k]), 1.0 / cabs(workl[iheig + k])); ++ d[k] = ARPACK_cplx(creal(temp) + creal(sigma), cimag(temp) + cimag(sigma)); ++#else ++ d[k] = 1.0 / workl[iheig + k] + sigma; ++#endif ++ } ++ // 60 ++ } ++ ++ // Eigenvector Purification step. Formally perform ++ // one of inverse subspace iteration. Only used ++ // for MODE = 3. See reference 3. ++ ++ if ((rvec) && (howmny == 0) && (TYP == SHIFTI)) ++ { ++ ++ // Purify the computed Ritz vectors by adding a ++ // little bit of the residual vector: ++ // T ++ // resid(:)*( e s ) / theta ++ // NCV ++ // where H s = s theta. ++ ++ for (j = 0; j < V->nconv; j++) ++ { ++ if ((creal(workl[iheig+j]) != 0.0) || (cimag(workl[iheig+j]) != 0.0)) ++ { ++#if defined(_MSC_VER) ++ // Complex division is not supported in MSVC ++ temp = _Cmulcr(conj(workl[iheig + j]), 1.0 / cabs(workl[iheig + j])); ++ workev[j] = _Cmulcc(workl[invsub + j*ldq + V->ncv], temp); ++#else ++ workev[j] = workl[invsub + j*ldq + V->ncv] / workl[iheig+j]; ++#endif ++ } ++ } ++ // 100 ++ ++ // Perform a rank one update to Z and ++ // purify all the Ritz vectors together. ++ ++ zgeru_(&V->n, &V->nconv, &cdbl1, resid, &int1, workev, &int1, z, &ldz); ++ } ++ ++ return; ++} ++ ++ ++void ++ARPACK_znaupd(struct ARPACK_arnoldi_update_vars_d *V, ARPACK_CPLX_TYPE* resid, ++ ARPACK_CPLX_TYPE* v, int ldv, int* ipntr, ARPACK_CPLX_TYPE* workd, ++ ARPACK_CPLX_TYPE* workl, double* rwork) ++{ ++ int bounds, ierr = 0, ih, iq, iw, ldh, ldq, next, iritz; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // perform basic checks ++ if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv < V->nev + 1) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if (V->maxiter <= 0) { ++ ierr = -4; ++ } else if ((V->which < 0) || (V->which > 5)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((V->mode < 1) || (V->mode > 3)) { ++ ierr = -10; ++ } else if ((V->mode == 1) && (V->bmat == 1)) { ++ ierr = -11; ++ } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ V->ido = 99; ++ return; ++ } ++ ++ if (V->tol <= 0.0) { ++ V-> tol = ulp; ++ } ++ ++ if ((V->shift != 0) && (V->shift != 1) && (V->shift != 2)) ++ { ++ V->shift = 1; ++ } ++ ++ // NP is the number of additional steps to ++ // extend the length NEV Lanczos factorization. ++ // NEV0 is the local variable designating the ++ // size of the invariant subspace desired. ++ ++ V->np = V->ncv - V->nev; ++ ++ for (int j = 0; j < 3 * (V->ncv*V->ncv) + 6*V->ncv; j++) ++ { ++ workl[j] = ARPACK_cplx(0.0, 0.0); ++ } ++ } ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:ncv*ncv) := generated Hessenberg matrix ++ // workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values ++ // workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds ++ // workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q ++ // workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace ++ // The final workspace is needed by subroutine zneigh called ++ // by znaup2 . Subroutine zneigh calls LAPACK routines for ++ // calculating eigenvalues and the last row of the eigenvector ++ // matrix. ++ ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ih = 0; ++ iritz = ih + ldh*V->ncv; ++ bounds = iritz + V->ncv; ++ iq = bounds + V->ncv; ++ iw = iq + ldq*V->ncv; ++ next = iw + (V->ncv*V->ncv) + 3*V->ncv; ++ ++ ipntr[3] = next; ++ ipntr[4] = ih; ++ ipntr[5] = iritz; ++ ipntr[6] = iq; ++ ipntr[7] = bounds; ++ ipntr[13] = iw; ++ ++ znaup2(V, resid, v, ldv, &workl[ih], ldh, &workl[iritz], &workl[bounds], ++ &workl[iq], ldq, &workl[iw], ipntr, workd, rwork); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP or shifts. ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ V->nconv = V->np; ++ ++ if (V->info < 0) { return; } ++ if (V->info == 2) { V->info = 3; } ++ ++ return; ++} ++ ++ ++void ++znaup2(struct ARPACK_arnoldi_update_vars_d *V, ARPACK_CPLX_TYPE* resid, ++ ARPACK_CPLX_TYPE* v, int ldv, ARPACK_CPLX_TYPE* h, int ldh, ++ ARPACK_CPLX_TYPE* ritz, ARPACK_CPLX_TYPE* bounds, ++ ARPACK_CPLX_TYPE* q, int ldq, ARPACK_CPLX_TYPE* workl, int* ipntr, ++ ARPACK_CPLX_TYPE* workd, double* rwork) ++{ ++ enum ARPACK_which temp_which; ++ int i, int1 = 1, j, tmp_int; ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ double temp = 0.0, rtemp; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->aup2_nev0 = V->nev; ++ V->aup2_np0 = V->np; ++ ++ // kplusp is the bound on the largest ++ // Lanczos factorization built. ++ // nconv is the current number of ++ // "converged" eigenvlues. ++ // iter is the counter on the current ++ // iteration step. ++ ++ V->aup2_kplusp = V->nev + V->np; ++ V->nconv = 0; ++ V->aup2_iter = 0; ++ ++ // Set flags for computing the first NEV ++ // steps of the Arnoldi factorization. ++ ++ V->aup2_getv0 = 1; ++ V->aup2_update = 0; ++ V->aup2_ushift = 0; ++ V->aup2_cnorm = 0; ++ ++ if (V->info != 0) ++ { ++ ++ // User provides the initial residual vector. ++ ++ V->aup2_initv = 1; ++ V->info = 0; ++ } else { ++ V->aup2_initv = 0; ++ } ++ } ++ ++ // Get a possibly random starting vector and ++ // force it into the range of the operator OP. ++ ++ if (V->aup2_getv0) ++ { ++ V->getv0_itry = 1; ++ zgetv0(V, V->aup2_initv, V->n, 0, v, ldv, resid, &V->aup2_rnorm, ipntr, workd); ++ if (V->ido != ido_DONE) { return; } ++ if (V->aup2_rnorm == 0.0) ++ { ++ V->info = -9; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_getv0 = 0; ++ V->ido = ido_FIRST; ++ } ++ ++ // Back from reverse communication : ++ // continue with update step ++ ++ if (V->aup2_update) { goto LINE20; } ++ ++ // Back from computing user specified shifts ++ ++ if (V->aup2_ushift) { goto LINE50; } ++ ++ // Back from computing residual norm ++ // at the end of the current iteration ++ ++ if (V->aup2_cnorm) { goto LINE100; } ++ ++ // Compute the first NEV steps of the Arnoldi factorization ++ ++ znaitr(V, 0, V->nev, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // ++ // M A I N ARNOLDI I T E R A T I O N L O O P ++ // Each iteration implicitly restarts the Arnoldi ++ // factorization in place. ++ // ++ ++LINE1000: ++ V->aup2_iter += 1; ++ ++ // Compute NP additional steps of the Arnoldi factorization. ++ // Adjust NP since NEV might have been updated by last call ++ // to the shift application routine dnapps . ++ ++ V->np = V->aup2_kplusp - V->nev; ++ V->ido = ido_FIRST; ++ ++LINE20: ++ V->aup2_update = 1; ++ ++ znaitr(V, V->nev, V->np, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_update = 0; ++ ++ // Compute the eigenvalues and corresponding error bounds ++ // of the current upper Hessenberg matrix. ++ ++ zneigh(&V->aup2_rnorm, V->aup2_kplusp, h, ldh, ritz, bounds, q, ldq, workl, rwork, &V->info); ++ ++ if (V->info != 0) ++ { ++ V->info = -8; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The wanted part of the spectrum and corresponding ++ // error bounds are in the last NEV loc. of RITZ, ++ // and BOUNDS respectively. ++ ++ V->nev = V->aup2_nev0; ++ V->np = V->aup2_np0; ++ ++ // Make a copy of Ritz values and the corresponding ++ // Ritz estimates obtained from zneigh . ++ tmp_int = V->aup2_kplusp * V->aup2_kplusp; ++ zcopy_(&V->aup2_kplusp, ritz, &int1, &workl[tmp_int], &int1); ++ tmp_int += V->aup2_kplusp; ++ zcopy_(&V->aup2_kplusp, bounds, &int1, &workl[tmp_int], &int1); ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The wanted part of the spectrum and corresponding ++ // bounds are in the last NEV loc. of RITZ ++ // BOUNDS respectively. ++ ++ zngets(V, &V->nev, &V->np, ritz, bounds); ++ ++ // Convergence test: currently we use the following criteria. ++ // The relative accuracy of a Ritz value is considered ++ // acceptable if: ++ // ++ // error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). ++ // ++ V->nconv = 0; ++ for (i = 0; i < V->nev; i++) ++ { ++ rtemp = fmax(eps23, cabs(ritz[V->np + i])); ++ if (cabs(bounds[V->np + i]) <= V->tol*rtemp) ++ { ++ V->nconv += 1; ++ } ++ } ++ // 25 ++ ++ // Count the number of unwanted Ritz values that have zero ++ // Ritz estimates. If any Ritz estimates are equal to zero ++ // then a leading block of H of order equal to at least ++ // the number of Ritz values with zero Ritz estimates has ++ // split off. None of these Ritz values may be removed by ++ // shifting. Decrease NP the number of shifts to apply. If ++ // no shifts may be applied, then prepare to exit ++ ++ // We are modifying V->np hence the temporary variable. ++ int nptemp = V->np; ++ ++ for (j = 0; j < nptemp; j++) ++ { ++ if ((creal(bounds[j]) == 0.0) && (cimag(bounds[j]) == 0.0)) ++ { ++ V->np -= 1; ++ V->nev += 1; ++ } ++ } ++ // 30 ++ ++ if ((V->nconv >= V->aup2_nev0) || (V->aup2_iter > V->maxiter) || (V->np == 0)) ++ { ++ ++ // Prepare to exit. Put the converged Ritz values ++ // and corresponding bounds in RITZ(1:NCONV) and ++ // BOUNDS(1:NCONV) respectively. Then sort. Be ++ // careful when NCONV > NP ++ ++ // Use h( 3,1 ) as storage to communicate ++ // rnorm to _neupd if needed ++ ++ h[2] = ARPACK_cplx(V->aup2_rnorm, 0.0); ++ ++ // Sort Ritz values so that converged Ritz ++ // values appear within the first NEV locations ++ // of ritz and bounds, and the most desired one ++ // appears at the front. ++ ++ // Translation note: Is this all because ARPACK did not have complex sort? ++ ++ if (V->which == which_LM) { temp_which = which_SM; } ++ if (V->which == which_SM) { temp_which = which_LM; } ++ if (V->which == which_LR) { temp_which = which_SR; } ++ if (V->which == which_SR) { temp_which = which_LR; } ++ if (V->which == which_LI) { temp_which = which_SI; } ++ if (V->which == which_SI) { temp_which = which_LI; } ++ ++ zsortc(temp_which, 1, V->aup2_kplusp, ritz, bounds); ++ ++ // Scale the Ritz estimate of each Ritz value ++ // by 1 / max(eps23,magnitude of the Ritz value). ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmax(eps23, cabs(ritz[j])); ++ bounds[j] = ARPACK_cplx(creal(bounds[j]) / temp, cimag(bounds[j]) / temp); ++ } ++ // 35 ++ ++ // Sort the Ritz values according to the scaled Ritz ++ // estimates. This will push all the converged ones ++ // towards the front of ritzr, ritzi, bounds ++ // (in the case when NCONV < NEV.) ++ ++ temp_which = which_LM; ++ zsortc(temp_which, 1, V->aup2_nev0, bounds, ritz); ++ ++ // Scale the Ritz estimate back to its original ++ // value. ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmax(eps23, cabs(ritz[j])); ++ bounds[j] = ARPACK_cplx(creal(bounds[j]) * temp, cimag(bounds[j]) * temp); ++ } ++ // 40 ++ ++ // Sort the converged Ritz values again so that ++ // the "threshold" value appears at the front of ++ // ritzr, ritzi and bound. ++ ++ zsortc(V->which, 1, V->nconv, ritz, bounds); ++ ++ if ((V->aup2_iter > V->maxiter) && (V->nconv < V->aup2_nev0)) ++ { ++ ++ // Max iterations have been exceeded. ++ ++ V->info = 1; ++ } ++ ++ if ((V->np == 0) && (V->nconv < V->aup2_nev0)) ++ { ++ ++ // No shifts to apply. ++ ++ V->info = 2; ++ } ++ ++ V->np = V->nconv; ++ V->iter = V->aup2_iter; ++ V->nev = V->nconv; ++ V->ido = ido_DONE; ++ return; ++ ++ } else if ((V->nconv < V->aup2_nev0) && (V->shift)) { ++ ++ // Do not have all the requested eigenvalues yet. ++ // To prevent possible stagnation, adjust the size ++ // of NEV. ++ ++ int nevbef = V->nev; ++ V->nev += (V->nconv > (V->np / 2) ? (V->np / 2) : V->nconv); ++ if ((V->nev == 1) && (V->aup2_kplusp >= 6)) { ++ V->nev = V->aup2_kplusp / 2; ++ } else if ((V->nev == 1) && (V->aup2_kplusp > 3)) { ++ V->nev = 2; ++ } ++ ++ V->np = V->aup2_kplusp - V->nev; ++ ++ // If the size of NEV was just increased ++ // resort the eigenvalues. ++ ++ if (nevbef < V->nev) { ++ zngets(V, &V->nev, &V->np, ritz, bounds); ++ } ++ } ++ ++ if (V->shift == 0) ++ { ++ ++ // User specified shifts: pop back out to get the shifts ++ // and return them in the first 2*NP locations of WORKL. ++ ++ V->aup2_ushift = 1; ++ V->ido = ido_USER_SHIFT; ++ return; ++ } ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // User specified shifts are returned ++ // in WORKL(1:2*NP) ++ ++ V->aup2_ushift = 0; ++ ++ if (V->shift != 1) ++ { ++ ++ // Move the NP shifts from WORKL to ++ // RITZR, RITZI to free up WORKL ++ // for non-exact shift case. ++ ++ zcopy_(&V->np, workl, &int1, ritz, &int1); ++ } ++ ++ // Apply the NP implicit shifts by QR bulge chasing. ++ // Each shift is applied to the whole upper Hessenberg ++ // matrix H. ++ // The first 2*N locations of WORKD are used as workspace. ++ ++ znapps(V->n, &V->nev, V->np, ritz, v, ldv, h, ldh, resid, q, ldq, workl, workd); ++ ++ // Compute the B-norm of the updated residual. ++ // Keep B*RESID in WORKD(1:N) to be used in ++ // the first step of the next call to dnaitr . ++ ++ V->aup2_cnorm = 1; ++ if (V->bmat) ++ { ++ zcopy_(&V->n, resid, &int1, &workd[V->n], &int1); ++ ipntr[0] = V->n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*RESID ++ ++ return; ++ } else { ++ zcopy_(&V->n, resid, &int1, workd, &int1); ++ } ++ ++LINE100: ++ ++ // Back from reverse communication; ++ // WORKD(1:N) := B*RESID ++ ++ if (V->bmat) ++ { ++ V->aup2_rnorm = sqrt(cabs(zdotc_(&V->n, resid, &int1, workd, &int1))); ++ } else { ++ V->aup2_rnorm = dznrm2_(&V->n, resid, &int1); ++ } ++ V->aup2_cnorm = 0; ++ ++ goto LINE1000; ++ ++ // ++ // E N D O F M A I N I T E R A T I O N L O O P ++ // ++ ++} ++ ++ ++static void ++znaitr(struct ARPACK_arnoldi_update_vars_d *V, int k, int np, ARPACK_CPLX_TYPE* resid, ++ double* rnorm, ARPACK_CPLX_TYPE* v, int ldv, ARPACK_CPLX_TYPE* h, int ldh, ++ int* ipntr, ARPACK_CPLX_TYPE* workd) ++{ ++ int i, infol, ipj, irj, ivj, jj, n, tmp_int; ++ double smlnum = unfl * ( V->n / ulp); ++ const double sq2o2 = sqrt(2.0) / 2.0; ++ ++ int int1 = 1; ++ double dbl1 = 1.0, temp1, tst1; ++ ARPACK_CPLX_TYPE cdbl1 = ARPACK_cplx(1.0, 0.0); ++ ARPACK_CPLX_TYPE cdblm1 = ARPACK_cplx(-1.0, 0.0); ++ ARPACK_CPLX_TYPE cdbl0 = ARPACK_cplx(0.0, 0.0); ++ ++ n = V->n; // n is constant, this is just for typing convenience ++ ipj = 0; ++ irj = ipj + n; ++ ivj = irj + n; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // Initial call to this routine ++ V->aitr_j = k; ++ V->info = 0; ++ V->aitr_step3 = 0; ++ V->aitr_step4 = 0; ++ V->aitr_orth1 = 0; ++ V->aitr_orth2 = 0; ++ V->aitr_restart = 0; ++ } ++ ++ // When in reverse communication mode one of: ++ // STEP3, STEP4, ORTH1, ORTH2, RSTART ++ // will be .true. when .... ++ // STEP3: return from computing OP*v_{j}. ++ // STEP4: return from computing B-norm of OP*v_{j} ++ // ORTH1: return from computing B-norm of r_{j+1} ++ // ORTH2: return from computing B-norm of ++ // correction to the residual vector. ++ // RSTART: return from OP computations needed by ++ // dgetv0. ++ ++ if (V->aitr_step3) { goto LINE50; } ++ if (V->aitr_step4) { goto LINE60; } ++ if (V->aitr_orth1) { goto LINE70; } ++ if (V->aitr_orth2) { goto LINE90; } ++ if (V->aitr_restart) { goto LINE30; } ++ ++ // Else this is the first step ++ ++ // ++ // A R N O L D I I T E R A T I O N L O O P ++ // ++ // Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) ++ ++LINE1000: ++ ++ // STEP 1: Check if the B norm of j-th residual ++ // vector is zero. Equivalent to determining whether ++ // an exact j-step Arnoldi factorization is present. ++ ++ V->aitr_betaj = *rnorm; ++ if (*rnorm > 0.0) { goto LINE40; } ++ ++ // Invariant subspace found, generate a new starting ++ // vector which is orthogonal to the current Arnoldi ++ // basis and continue the iteration. ++ ++ V->aitr_betaj = 0.0; ++ V->getv0_itry = 1; ++ ++LINE20: ++ V->aitr_restart = 1; ++ V->ido = ido_FIRST; ++ ++LINE30: ++ ++ // If in reverse communication mode and aitr_restart = 1, flow returns here. ++ ++ zgetv0(V, 0, n, V->aitr_j, v, ldv, resid, rnorm, ipntr, workd); ++ ++ if (V->ido != ido_DONE) { return; } ++ V->aitr_ierr = V->info; ++ if (V->aitr_ierr < 0) ++ { ++ V->getv0_itry += 1; ++ if (V->getv0_itry <= 3) { goto LINE20; } ++ ++ // Give up after several restart attempts. ++ // Set INFO to the size of the invariant subspace ++ // which spans OP and exit. ++ ++ V->info = V->aitr_j; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++LINE40: ++ ++ // STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm ++ // Note that p_{j} = B*r_{j-1}. In order to avoid overflow ++ // when reciprocating a small RNORM, test against lower ++ // machine bound. ++ ++ zcopy_(&n, resid, &int1, &v[ldv*V->aitr_j], &int1); ++ ++ if (*rnorm >= unfl) ++ { ++ temp1 = 1.0 / *rnorm; ++ zdscal_(&n, &temp1, &v[ldv*V->aitr_j], &int1); ++ zdscal_(&n, &temp1, &workd[ipj], &int1); ++ } else { ++ zlascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &v[ldv*V->aitr_j], &n, &infol); ++ zlascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &workd[ipj], &n, &infol); ++ } ++ ++ // STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} ++ // Note that this is not quite yet r_{j}. See STEP 4 ++ ++ V->aitr_step3 = 1; ++ zcopy_(&n, &v[ldv*(V->aitr_j)], &int1, &workd[ivj], &int1); ++ ipntr[0] = ivj; ++ ipntr[1] = irj; ++ ipntr[2] = ipj; ++ V->ido = ido_OPX; ++ ++ // Exit in order to compute OP*v_{j} ++ ++ return; ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // WORKD(IRJ:IRJ+N-1) := OP*v_{j} ++ // if step3 = .true. ++ ++ V->aitr_step3 = 0; ++ ++ // Put another copy of OP*v_{j} into RESID. ++ ++ zcopy_(&n, &workd[irj], &int1, resid, &int1); ++ ++ // STEP 4: Finish extending the Arnoldi ++ // factorization to length j. ++ ++ if (V->bmat) ++ { ++ V->aitr_step4 = 1; ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*OP*v_{j} ++ ++ return; ++ } else { ++ zcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE60: ++ ++ // Back from reverse communication; ++ // WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} ++ // if step4 = .true. ++ ++ V->aitr_step4 = 0; ++ ++ // The following is needed for STEP 5. ++ // Compute the B-norm of OP*v_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_wnorm = sqrt(cabs(zdotc_(&n, resid, &int1, &workd[ipj], &int1))); ++ } else { ++ V->aitr_wnorm = dznrm2_(&n, resid, &int1); ++ } ++ ++ // Compute the j-th residual corresponding ++ // to the j step factorization. ++ // Use Classical Gram Schmidt and compute: ++ // w_{j} <- V_{j}^T * B * OP * v_{j} ++ // r_{j} <- OP*v_{j} - V_{j} * w_{j} ++ ++ // Compute the j Fourier coefficients w_{j} ++ // WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. ++ tmp_int = V->aitr_j + 1; ++ zgemv_("C", &n, &tmp_int, &cdbl1, v, &ldv, &workd[ipj], &int1, &cdbl0, &h[ldh*(V->aitr_j)], &int1); ++ ++ // Orthogonalize r_{j} against V_{j}. ++ // RESID contains OP*v_{j}. See STEP 3. ++ ++ zgemv_("N", &n, &tmp_int, &cdblm1, v, &ldv, &h[ldh*(V->aitr_j)], &int1, &cdbl1, resid, &int1); ++ ++ if (V->aitr_j > 0) { h[V->aitr_j + ldh*(V->aitr_j-1)] = ARPACK_cplx(V->aitr_betaj, 0.0); } ++ ++ V->aitr_orth1 = 1; ++ if (V->bmat) ++ { ++ zcopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j} ++ ++ return; ++ } else { ++ zcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE70: ++ ++ // Back from reverse communication if ORTH1 = .true. ++ // WORKD(IPJ:IPJ+N-1) := B*r_{j}. ++ ++ V->aitr_orth1 = 0; ++ ++ // Compute the B-norm of r_{j}. ++ ++ if (V->bmat) ++ { ++ *rnorm = sqrt(cabs(zdotc_(&n, resid, &int1, &workd[ipj], &int1))); ++ } else { ++ *rnorm = dznrm2_(&n, resid, &int1); ++ } ++ ++ // STEP 5: Re-orthogonalization / Iterative refinement phase ++ // Maximum NITER_ITREF tries. ++ // ++ // s = V_{j}^T * B * r_{j} ++ // r_{j} = r_{j} - V_{j}*s ++ // alphaj = alphaj + s_{j} ++ // ++ // The stopping criteria used for iterative refinement is ++ // discussed in Parlett's book SEP, page 107 and in Gragg & ++ // Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. ++ // Determine if we need to correct the residual. The goal is ++ // to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || ++ // The following test determines whether the sine of the ++ // angle between OP*x and the computed residual is less ++ // than or equal to 0.7071. ++ ++ if (*rnorm > sq2o2*V->aitr_wnorm) { goto LINE100; } ++ V->aitr_iter = 0; ++ ++ // Enter the Iterative refinement phase. If further ++ // refinement is necessary, loop back here. The loop ++ // variable is ITER. Perform a step of Classical ++ // Gram-Schmidt using all the Arnoldi vectors V_{j} ++ ++LINE80: ++ ++ // Compute V_{j}^T * B * r_{j}. ++ // WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). ++ tmp_int = V->aitr_j + 1; ++ zgemv_("C", &n, &tmp_int, &cdbl1, v, &ldv, &workd[ipj], &int1, &cdbl0, &workd[irj], &int1); ++ ++ // Compute the correction to the residual: ++ // r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). ++ // The correction to H is v(:,1:J)*H(1:J,1:J) ++ // + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. ++ ++ zgemv_("N", &n, &tmp_int, &cdblm1, v, &ldv, &workd[irj], &int1, &cdbl1, resid, &int1); ++ zaxpy_(&tmp_int, &cdbl1, &workd[irj], &int1, &h[ldh*(V->aitr_j)], &int1); ++ ++ V->aitr_orth2 = 1; ++ ++ if (V->bmat) ++ { ++ zcopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j}. ++ // r_{j} is the corrected residual. ++ ++ return; ++ } else { ++ zcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE90: ++ ++ // Back from reverse communication if ORTH2 = .true. ++ // Compute the B-norm of the corrected residual r_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_rnorm1 = sqrt(cabs(zdotc_(&n, resid, &int1, &workd[ipj], &int1))); ++ } else { ++ V->aitr_rnorm1 = dznrm2_(&n, resid, &int1); ++ } ++ ++ // Determine if we need to perform another ++ // step of re-orthogonalization. ++ ++ if (V->aitr_rnorm1 > sq2o2*(*rnorm)) ++ { ++ ++ // No need for further refinement. ++ // The cosine of the angle between the ++ // corrected residual vector and the old ++ // residual vector is greater than 0.717 ++ // In other words the corrected residual ++ // and the old residual vector share an ++ // angle of less than arcCOS(0.717) ++ ++ *rnorm = V->aitr_rnorm1; ++ ++ } else { ++ ++ // Another step of iterative refinement step ++ // is required. ++ ++ *rnorm = V->aitr_rnorm1; ++ V->aitr_iter += 1; ++ if (V->aitr_iter < 2) { goto LINE80; } ++ ++ // Otherwise RESID is numerically in the span of V ++ ++ for (jj = 0; jj < n; jj++) ++ { ++ resid[jj] = ARPACK_cplx(0.0, 0.0); ++ } ++ *rnorm = 0.0; ++ } ++ ++LINE100: ++ ++ V->aitr_restart = 0; ++ V->aitr_orth2 = 0; ++ ++ // STEP 6: Update j = j+1; Continue ++ ++ V->aitr_j += 1; ++ ++ if (V->aitr_j >= k + np) ++ { ++ V->ido = ido_DONE; ++ for (i = (k > 0 ? k-1 : k); i < k + np - 1; i++) ++ { ++ ++ // Check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine dlahqr ++ ++ tst1 = cabs(h[i + ldh*i]) + cabs(h[i+1 + ldh*(i+1)]); ++ if (tst1 == 0.0) ++ { ++ tmp_int = k + np; ++ // zlanhs(norm, n, a, lda, work) with "work" being double type ++ // Recasting complex workspace to double for scratch space. ++ tst1 = zlanhs_("1", &tmp_int, h, &ldh, (double*)&workd[n]); ++ } ++ if (cabs(h[i+1 + ldh*i]) <= fmax(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = ARPACK_cplx(0.0, 0.0); ++ } ++ } ++ // 110 ++ return; ++ } ++ goto LINE1000; ++ ++} ++ ++ ++static void ++znapps(int n, int* kev, int np, ARPACK_CPLX_TYPE* shift, ARPACK_CPLX_TYPE* v, ++ int ldv, ARPACK_CPLX_TYPE* h, int ldh, ARPACK_CPLX_TYPE* resid, ++ ARPACK_CPLX_TYPE* q, int ldq, ARPACK_CPLX_TYPE* workl, ++ ARPACK_CPLX_TYPE* workd) ++{ ++ int i, j, jj, int1 = 1, istart, iend = 0, tmp_int; ++ double smlnum = unfl * ( n / ulp); ++ double c, tst1; ++ double tmp_dbl; ++ ARPACK_CPLX_TYPE f, g, h11, h21, sigma, s, s2, r, t, tmp_cplx; ++ ++#if defined(_MSC_VER) ++ ARPACK_CPLX_TYPE tmp_cplx2; ++#endif ++ ++ ARPACK_CPLX_TYPE cdbl1 = ARPACK_cplx(1.0, 0.0); ++ ARPACK_CPLX_TYPE cdbl0 = ARPACK_cplx(0.0, 0.0); ++ ++ int kplusp = *kev + np; ++ ++ // Initialize Q to the identity to accumulate ++ // the rotations and reflections ++ zlaset_("G", &kplusp, &kplusp, &cdbl0, &cdbl1, q, &ldq); ++ ++ // Quick return if there are no shifts to apply ++ ++ if (np == 0) { return; } ++ ++ // Chase the bulge with the application of each ++ // implicit shift. Each shift is applied to the ++ // whole matrix including each block. ++ ++ for (jj = 0; jj < np; jj++) ++ { ++ sigma = shift[jj]; ++ istart = 0; ++ ++ while (istart < kplusp - 1) ++ { ++ for (iend = istart; iend < kplusp - 1; iend++) ++ { ++ tst1 = fabs(creal(h[iend + ldh*iend])) + fabs(cimag(h[iend + ldh*iend])) + ++ fabs(creal(h[iend+1 + ldh*(iend+1)])) + fabs(cimag(h[iend+1 + ldh*(iend+1)])); ++ if (tst1 == 0.0) ++ { ++ tmp_int = kplusp - jj; ++ zlanhs_("1", &tmp_int, h, &ldh, (double*)workl); ++ } ++ if (fabs(creal(h[iend+1 + ldh*iend])) <= fmax(ulp*tst1, smlnum)) ++ { ++ break; ++ } ++ } ++ if ((istart == iend) || (istart >= *kev)) ++ { ++ ++ // No reason to apply a shift to block of order 1 ++ // or if the current block starts after the point ++ // of compression since we'll discard this stuff. ++ ++ istart += 1; ++ continue; ++ ++ } else if (iend < kplusp - 1) { ++ ++ // Valid block found and it's not the entire remaining array ++ // Clean up the noise ++ ++ h[iend+1 + ldh*iend] = ARPACK_cplx(0.0, 0.0); ++ } ++ ++ h11 = h[istart + ldh*istart]; ++ h21 = h[istart + 1 + ldh*istart]; ++ // f = h11 - sigma; ++ f = ARPACK_cplx(creal(h11)-creal(sigma), cimag(h11)-cimag(sigma)); ++ g = h21; ++ ++ for (i = istart; i < iend; i++) ++ { ++ ++ // Construct the plane rotation G to zero out the bulge ++ ++ zlartg_(&f, &g, &c, &s, &r); ++ if (i > istart) ++ { ++ h[i + ldh*(i-1)] = r; ++ h[i + 1 + ldh*(i-1)] = ARPACK_cplx(0.0, 0.0); ++ } ++ tmp_int = kplusp - i; ++ zrot_(&tmp_int, &h[i + ldh*i], &ldh, &h[i + 1 + ldh*i], &ldh, &c, &s); ++ // z = a + bi, -conj(z) = -a + bi ++ s2 = conj(s); ++ tmp_int = (i + 2 > iend ? iend : i + 2) + 1; ++ zrot_(&tmp_int, &h[ldh*i], &int1, &h[ldh*(i+1)], &int1, &c, &s2); ++ tmp_int = (i + jj + 2 > kplusp ? kplusp : i + jj + 2); ++ zrot_(&tmp_int, &q[ldq*i], &int1, &q[ldq*(i+1)], &int1, &c, &s2); ++ ++ if (i < iend - 1) ++ { ++ f = h[i + 1 + ldh*i]; ++ g = h[i + 2 + ldh*i]; ++ } ++ } ++ istart = iend + 1; ++ } ++ } ++ ++ // Perform a similarity transformation that makes ++ // sure that H will have non negative sub diagonals ++ ++ for (j = 0; j < *kev; j++) ++ { ++ if ((creal(h[j+1 + ldh*j]) < 0.0) || (cimag(h[j+1 + ldh*j]) != 0.0)) ++ { ++ tmp_dbl = cabs(h[j+1 + ldh*j]); ++ t = ARPACK_cplx(creal(h[j+1 + ldh*j]) / tmp_dbl, ++ cimag(h[j+1 + ldh*j]) / tmp_dbl); ++ ++ tmp_cplx = conj(t); ++ tmp_int = kplusp - j; ++ zscal_(&tmp_int, &tmp_cplx, &h[j+1 + ldh*j], &ldh); ++ ++ tmp_int = (j+3 > kplusp ? kplusp : j+3); ++ zscal_(&tmp_int, &t, &h[ldh*(j+1)], &int1); ++ ++ tmp_int = (j+np+2 > kplusp ? kplusp : j+np+2); ++ zscal_(&tmp_int, &t, &q[ldq*(j+1)], &int1); ++ ++ h[j+1 + ldh*j] = ARPACK_cplx(creal(h[j+1 + ldh*j]), 0.0); ++ } ++ } ++ // 120 ++ ++ for (i = 0; i < *kev; i++) ++ { ++ ++ // Final check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine zlahqr. ++ // Note: Since the subdiagonals of the ++ // compressed H are nonnegative real numbers, ++ // we take advantage of this. ++ ++ tst1 = fabs(creal(h[i + ldh*i])) + fabs(creal(h[i+1 + ldh*(i+1)])) + ++ fabs(cimag(h[i + ldh*i])) + fabs(cimag(h[i+1 + ldh*(i+1)])); ++ if (tst1 == 0.0) ++ { ++ tst1 = zlanhs_("1", kev, h, &ldh, (double*)workl); ++ } ++ if (creal(h[i+1 + ldh*i]) <= fmax(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = ARPACK_cplx(0.0, 0.0); ++ } ++ } ++ // 130 ++ ++ // Compute the (kev+1)-st column of (V*Q) and ++ // temporarily store the result in WORKD(N+1:2*N). ++ // This is needed in the residual update since we ++ // cannot GUARANTEE that the corresponding entry ++ // of H would be zero as in exact arithmetic. ++ ++ if (creal(h[*kev + ldh*(*kev-1)]) > 0.0) ++ { ++ zgemv_("N", &n, &kplusp, &cdbl1, v, &ldv, &q[(*kev)*ldq], &int1, &cdbl0, &workd[n], &int1); ++ } ++ ++ // Compute column 1 to kev of (V*Q) in backward order ++ // taking advantage of the upper Hessenberg structure of Q. ++ ++ for (i = 0; i < *kev; i++) ++ { ++ tmp_int = kplusp - i; ++ zgemv_("N", &n, &tmp_int, &cdbl1, v, &ldv, &q[(*kev-i-1)*ldq], &int1, &cdbl0, workd, &int1); ++ zcopy_(&n, workd, &int1, &v[(kplusp-i-1)*ldv], &int1); ++ } ++ ++ // Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). ++ ++ zlacpy_("A", &n, kev, &v[ldv*(kplusp - *kev)], &ldv, v, &ldv); ++ ++ // Copy the (kev+1)-st column of (V*Q) in the appropriate place ++ ++ if (creal(h[*kev + ldh*(*kev-1)]) > 0.0) { ++ zcopy_(&n, &workd[n], &int1, &v[ldv*(*kev)], &int1); ++ } ++ ++ // Update the residual vector: ++ // r <- sigmak*r + betak*v(:,kev+1) ++ // where ++ // sigmak = (e_{kplusp}'*Q)*e_{kev} ++ // betak = e_{kev+1}'*H*e_{kev} ++ ++ zscal_(&n, &q[kplusp-1 + ldq*(*kev-1)], resid, &int1); ++ ++ if (creal(h[*kev + ldh*(*kev-1)]) > 0.0) ++ { ++ zaxpy_(&n, &h[*kev + ldh*(*kev-1)], &v[ldv*(*kev)], &int1, resid, &int1); ++ } ++ ++ return; ++} ++ ++ ++static void ++zneigh(double* rnorm, int n, ARPACK_CPLX_TYPE* h, int ldh, ARPACK_CPLX_TYPE* ritz, ++ ARPACK_CPLX_TYPE* bounds, ARPACK_CPLX_TYPE* q, int ldq, ARPACK_CPLX_TYPE* workl, ++ double* rwork, int* ierr) ++{ ++ int select[1] = { 0 }; ++ int int1 = 1, j; ++ double temp; ++ ARPACK_CPLX_TYPE vl[1] = { 0.0 }; ++ ARPACK_CPLX_TYPE c1 = ARPACK_cplx(1.0, 0.0), c0 = ARPACK_cplx(0.0, 0.0); ++ ++ // 1. Compute the eigenvalues, the last components of the ++ // corresponding Schur vectors and the full Schur form T ++ // of the current upper Hessenberg matrix H. ++ // zlahqr returns the full Schur form of H ++ // in WORKL(1:N**2), and the Schur vectors in q. ++ ++ zlacpy_("A", &n, &n, h, &ldh, workl, &n); ++ zlaset_("A", &n, &n, &c0, &c1, q, &ldq); ++ zlahqr_(&int1, &int1, &n, &int1, &n, workl, &ldh, ritz, &int1, &n, q, &ldq, ierr); ++ ++ if (*ierr != 0) { return; } ++ ++ zcopy_(&n, &q[n-2], &ldq, bounds, &int1); ++ ++ // 2. Compute the eigenvectors of the full Schur form T and ++ // apply the Schur vectors to get the corresponding ++ // eigenvectors. ++ ++ ztrevc_("R", "B", select, &n, workl, &n, vl, &n, q, &ldq, &n, &n, &workl[n*n], rwork, ierr); ++ ++ if (*ierr != 0) { return; } ++ ++ // Scale the returning eigenvectors so that their ++ // euclidean norms are all one. LAPACK subroutine ++ // ztrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1; here the magnitude of a complex ++ // number (x,y) is taken to be |x| + |y|. ++ ++ for (j = 0; j < n; j++) ++ { ++ temp = 1.0 / dznrm2_(&n, &q[j*ldq], &int1); ++ zdscal_(&n, &temp, &q[j*ldq], &int1); ++ } ++ ++ // Compute the Ritz estimates ++ ++ zcopy_(&n, &q[n-1], &n, bounds, &int1); ++ zdscal_(&n, rnorm, bounds, &int1); ++ ++ return; ++} ++ ++ ++void ++zngets(struct ARPACK_arnoldi_update_vars_d *V, int* kev, int* np, ++ ARPACK_CPLX_TYPE* ritz, ARPACK_CPLX_TYPE* bounds) ++{ ++ ++ zsortc(V->which, 1, *kev + *np, ritz, bounds); ++ ++ if (V->shift == 1) ++ { ++ ++ // Sort the unwanted Ritz values used as shifts so that ++ // the ones with largest Ritz estimates are first ++ // This will tend to minimize the effects of the ++ // forward instability of the iteration when they shifts ++ // are applied in subroutine znapps. ++ // Be careful and use 'SM' since we want to sort BOUNDS! ++ ++ zsortc(which_SM, 1, *np, bounds, ritz); ++ } ++ ++ return; ++} ++ ++ ++static void ++zgetv0(struct ARPACK_arnoldi_update_vars_d *V, int initv, int n, int j, ++ ARPACK_CPLX_TYPE* v, int ldv, ARPACK_CPLX_TYPE* resid, double* rnorm, ++ int* ipntr, ARPACK_CPLX_TYPE* workd) ++{ ++ int jj, int1 = 1; ++ const double sq2o2 = sqrt(2.0) / 2.0; ++ ARPACK_CPLX_TYPE c0 = ARPACK_cplx(0.0, 0.0); ++ ARPACK_CPLX_TYPE c1 = ARPACK_cplx(1.0, 0.0); ++ ARPACK_CPLX_TYPE cm1 = ARPACK_cplx(-1.0, 0.0); ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->info = 0; ++ V->getv0_iter = 0; ++ V->getv0_first = 0; ++ V->getv0_orth = 0; ++ ++ // Possibly generate a random starting vector in RESID ++ // Skip if this the return of ido_RANDOM. ++ ++ if (!(initv)) ++ { ++ // Request a random vector from the user into resid ++ V->ido = ido_RANDOM; ++ return; ++ } else { ++ // If initv = 1, then the user has provided a starting vector ++ // in RESID. We need to copy it into workd[n] and perform an OP(x0). ++ // Change the ido but don't exit to join back to the flow. ++ V->ido = ido_RANDOM; ++ } ++ } ++ ++ // Back from random vector generation ++ if (V->ido == ido_RANDOM) ++ { ++ // Force the starting vector into the range of OP to handle ++ // the generalized problem when B is possibly (singular). ++ ++ if (V->getv0_itry == 1) ++ { ++ ipntr[0] = 0; ++ ipntr[1] = n; ++ zcopy_(&n, resid, &int1, workd, &int1); ++ V->ido = ido_RANDOM_OPX; ++ return; ++ } else if ((V->getv0_itry > 1) && (V->bmat == 1)) ++ { ++ zcopy_(&n, resid, &int1, &workd[n], &int1); ++ } ++ } ++ ++ // Back from computing OP*(initial-vector) ++ ++ if (V->getv0_first) { goto LINE20; } ++ ++ // Back from computing OP*(orthogonalized-vector) ++ ++ if (V->getv0_orth) { goto LINE40; } ++ ++ // Starting vector is now in the range of OP; r = OP*r; ++ // Compute B-norm of starting vector. ++ ++ V->getv0_first = 1; ++ if (V->getv0_itry == 1) ++ { ++ zcopy_(&n, &workd[n], &int1, resid, &int1); ++ } ++ if (V->bmat) ++ { ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ zcopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE20: ++ V->getv0_first = 0; ++ if (V->bmat) ++ { ++ V->getv0_rnorm0 = sqrt(cabs(zdotc_(&n, resid, &int1, workd, &int1))); ++ } else { ++ V->getv0_rnorm0 = dznrm2_(&n, resid, &int1); ++ } ++ *rnorm = V->getv0_rnorm0; ++ ++ // Exit if this is the very first Arnoldi step ++ ++ if (j == 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Otherwise need to B-orthogonalize the starting vector against ++ // the current Arnoldi basis using Gram-Schmidt with iter. ref. ++ // This is the case where an invariant subspace is encountered ++ // in the middle of the Arnoldi factorization. ++ // ++ // s = V^{H}*B*r; r = r - V*s; ++ // ++ // Stopping criteria used for iter. ref. is discussed in ++ // Parlett's book, page 107 and in Gragg & Reichel TOMS paper. ++ ++ V->getv0_orth = 1; ++ ++LINE30: ++ ++ zgemv_("C", &n, &j, &c1, v, &ldv, workd, &int1, &c0, &workd[n], &int1); ++ zgemv_("N", &n, &j, &cm1, v, &ldv, &workd[n], &int1, &c1, resid, &int1); ++ ++ // Compute the B-norm of the orthogonalized starting vector ++ ++ if (V->bmat) ++ { ++ zcopy_(&n, resid, &int1, &workd[n], &int1); ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ zcopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE40: ++ ++ if (V->bmat) ++ { ++ *rnorm = sqrt(cabs(zdotc_(&n, resid, &int1, workd, &int1))); ++ } else { ++ *rnorm = dznrm2_(&n, resid, &int1); ++ } ++ ++ // Check for further orthogonalization. ++ ++ if (*rnorm > sq2o2*V->getv0_rnorm0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->getv0_iter += 1; ++ ++ if (V->getv0_iter < 2) ++ { ++ ++ // Perform iterative refinement step ++ ++ V->getv0_rnorm0 = *rnorm; ++ goto LINE30; ++ } else { ++ ++ // Iterative refinement step "failed" ++ ++ for (jj = 0; jj < n; jj++) { resid[jj] = ARPACK_cplx(0.0, 0.0); } ++ *rnorm = 0.0; ++ V->info = -1; ++ } ++ ++ V->ido = ido_DONE; ++ return; ++} ++ ++ ++static void ++zsortc(const enum ARPACK_which w, const int apply, const int n, ARPACK_CPLX_TYPE* x, ARPACK_CPLX_TYPE* y) ++{ ++ int i, igap, j; ++ ARPACK_CPLX_TYPE temp; ++ ARPACK_compare_cfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortc_LM; ++ break; ++ case which_SM: ++ f = sortc_SM; ++ break; ++ case which_LR: ++ f = sortc_LR; ++ break; ++ case which_LI: ++ f = sortc_LI; ++ break; ++ case which_SR: ++ f = sortc_SR; ++ break; ++ case which_SI: ++ f = sortc_SI; ++ break; ++ default: ++ f = sortc_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(x[j], x[j+igap])) ++ { ++ if (j < 0) { break; } ++ temp = x[j]; ++ x[j] = x[j+igap]; ++ x[j+igap] = temp; ++ ++ if (apply) ++ { ++ temp = y[j]; ++ y[j] = y[j+igap]; ++ y[j+igap] = temp; ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++} ++ ++ ++static int sortc_LM(const ARPACK_CPLX_TYPE x, const ARPACK_CPLX_TYPE y) { return (cabs(x) > cabs(y)); } ++static int sortc_SM(const ARPACK_CPLX_TYPE x, const ARPACK_CPLX_TYPE y) { return (cabs(x) < cabs(y)); } ++static int sortc_LR(const ARPACK_CPLX_TYPE x, const ARPACK_CPLX_TYPE y) { return (creal(x) > creal(y)); } ++static int sortc_SR(const ARPACK_CPLX_TYPE x, const ARPACK_CPLX_TYPE y) { return (creal(x) < creal(y)); } ++static int sortc_LI(const ARPACK_CPLX_TYPE x, const ARPACK_CPLX_TYPE y) { return (cimag(x) > cimag(y)); } ++static int sortc_SI(const ARPACK_CPLX_TYPE x, const ARPACK_CPLX_TYPE y) { return (cimag(x) < cimag(y)); } ++ ++ ++// zdotc is the complex conjugate dot product of two complex vectors. ++// Due some historical reasons, this function can cause segfaults on some ++// platforms. Hence implemented here instead of using the BLAS version. ++static ARPACK_CPLX_TYPE ++zdotc_(const int* n, const ARPACK_CPLX_TYPE* restrict x, const int* incx, const ARPACK_CPLX_TYPE* restrict y, const int* incy) ++{ ++ ARPACK_CPLX_TYPE result = ARPACK_cplx(0.0, 0.0); ++#ifdef _MSC_VER ++ ARPACK_CPLX_TYPE temp = ARPACK_cplx(0.0, 0.0); ++#endif ++ if (*n <= 0) { return result; } ++ if ((*incx == 1) && (*incy == 1)) ++ { ++ for (int i = 0; i < *n; i++) ++ { ++#ifdef _MSC_VER ++ temp = _Cmulcc(x[i], conj(y[i])); ++ result = ARPACK_cplx(creal(result) + creal(temp), cimag(result) + cimag(temp)); ++#else ++ result = result + (x[i] * conj(y[i])); ++#endif ++ } ++ ++ } else { ++ ++ for (int i = 0; i < *n; i++) ++ { ++#ifdef _MSC_VER ++ temp = _Cmulcc(x[i * (*incx)], conj(y[i * (*incy)])); ++ result = ARPACK_cplx(creal(result) + creal(temp), cimag(result) + cimag(temp)); ++#else ++ result = result + (x[i * (*incx)] * conj(y[i * (*incy)])); ++#endif ++ } ++ } ++ ++ return result; ++} +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.h +new file mode 100644 +index 0000000000..47302631cf +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_double_complex.h +@@ -0,0 +1,45 @@ ++#ifndef _ARPACK_N_DOUBLE_COMPLEX_H ++#define _ARPACK_N_DOUBLE_COMPLEX_H ++ ++#include "_arpack.h" ++ ++// BLAS Routines used ++void zaxpy_(int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* x, int* incx, ARPACK_CPLX_TYPE* y, int* incy); ++void zcopy_(int* n, ARPACK_CPLX_TYPE* x, int* incx, ARPACK_CPLX_TYPE* y, int* incy); ++void zgeru_(int* m, int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* x, int* incx, ARPACK_CPLX_TYPE* y, int* incy, ARPACK_CPLX_TYPE* a, int* lda); ++double dznrm2_(int* n, ARPACK_CPLX_TYPE* x, int* incx); ++void zscal_(int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* x, int* incx); ++void zdscal_(int* n, double* da, ARPACK_CPLX_TYPE* zx, int* incx); ++void zgemv_(char* trans, int* m, int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* a, int* lda, ARPACK_CPLX_TYPE* x, int* incx, ARPACK_CPLX_TYPE* beta, ARPACK_CPLX_TYPE* y, int* incy); ++void zrot_(int* n, ARPACK_CPLX_TYPE* cx, int* incx, ARPACK_CPLX_TYPE* cy, int* incy, double* c, ARPACK_CPLX_TYPE* s); ++void ztrmm_(char* side, char* uplo, char* transa, char* diag, int* m, int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* a, int* lda, ARPACK_CPLX_TYPE* b, int* ldb); ++ ++// LAPACK Routines used ++void zgeqr2_(int* m, int* n, ARPACK_CPLX_TYPE* a, int* lda, ARPACK_CPLX_TYPE* tau, ARPACK_CPLX_TYPE* work, int* info); ++void zlacpy_(char* uplo, int* m, int* n, ARPACK_CPLX_TYPE* a, int* lda, ARPACK_CPLX_TYPE* b, int* ldb); ++void zlahqr_(int* wantt, int* wantz, int* n, int* ilo, int* ihi, ARPACK_CPLX_TYPE* h, int* ldh, ARPACK_CPLX_TYPE* w, int* iloz, int* ihiz, ARPACK_CPLX_TYPE* z, int* ldz, int* info ); ++double zlanhs_(char* norm, int* n, ARPACK_CPLX_TYPE* a, int* lda, double* work); ++void zlarf_(char* side, int* m, int* n, ARPACK_CPLX_TYPE* v, int* incv, ARPACK_CPLX_TYPE* tau, ARPACK_CPLX_TYPE* c, int* ldc, ARPACK_CPLX_TYPE* work); ++void zlarfg_(int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* x, int* incx, ARPACK_CPLX_TYPE* tau); ++void zlartg_(ARPACK_CPLX_TYPE* f, ARPACK_CPLX_TYPE* g, double* c, ARPACK_CPLX_TYPE* s, ARPACK_CPLX_TYPE* r); ++void zlascl_(char* mtype, int* kl, int* ku, double* cfrom, double* cto, int* m, int* n, ARPACK_CPLX_TYPE* a, int* lda, int* info); ++void zlaset_(char* uplo, int* m, int* n, ARPACK_CPLX_TYPE* alpha, ARPACK_CPLX_TYPE* beta, ARPACK_CPLX_TYPE* a, int* lda); ++void ztrevc_(char* side, char* howmny, int* select, int* n, ARPACK_CPLX_TYPE* t, int* ldt, ARPACK_CPLX_TYPE* vl, int* ldvl, ARPACK_CPLX_TYPE* vr, int* ldvr, int* mm, int* m, ARPACK_CPLX_TYPE* work, double* rwork, int* info); ++void ztrsen_(char* job, char* compq, int* select, int* n, ARPACK_CPLX_TYPE* t, int* ldt, ARPACK_CPLX_TYPE* q, int* ldq, ARPACK_CPLX_TYPE* w, int* m, double* s, double* sep, ARPACK_CPLX_TYPE* work, int* lwork, int* info); ++void zunm2r_(char* side, char* trans, int* m, int* n, int* k, ARPACK_CPLX_TYPE* a, int* lda, ARPACK_CPLX_TYPE* tau, ARPACK_CPLX_TYPE* c, int* ldc, ARPACK_CPLX_TYPE* work, int* info); ++ ++#if defined(_MSC_VER) ++ // MSVC definitions ++ #include // MSVC C++ header ++ typedef _Dcomplex ARPACK_CPLX_TYPE; ++ #define ARPACK_cplx(real, imag) ((_Dcomplex){real, imag}) ++ ++#else ++ // C99 compliant compilers ++ #include ++ typedef double complex ARPACK_CPLX_TYPE; ++ #define ARPACK_cplx(real, imag) ((real) + (imag)*I) ++ ++#endif ++ ++#endif +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.c b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.c +new file mode 100644 +index 0000000000..c24042ec03 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.c +@@ -0,0 +1,2101 @@ ++#include "_arpack_n_single.h" ++ ++typedef int ARPACK_compare_cfunc(const float, const float, const float, const float); ++ ++static int sortc_LM(const float, const float, const float, const float); ++static int sortc_SM(const float, const float, const float, const float); ++static int sortc_LR(const float, const float, const float, const float); ++static int sortc_SR(const float, const float, const float, const float); ++static int sortc_LI(const float, const float, const float, const float); ++static int sortc_SI(const float, const float, const float, const float); ++ ++static const float unfl = 1.1754943508222875e-38; ++// static const float ovfl = 1.0 / 1.1754943508222875e-38; ++static const float ulp = 1.1920928955078125e-07; ++ ++static void snaup2(struct ARPACK_arnoldi_update_vars_s*, float*, float*, int, float*, int, float*, float*, float*, float*, int, float*, int*, float*); ++static void snconv(int n, float* ritzr, float* ritzi, float* bounds, const float tol, int* nconv); ++static void sneigh(float*,int,float*,int,float*,float*,float*,float*,int,float*,int*); ++static void snaitr(struct ARPACK_arnoldi_update_vars_s*,int,int,float*,float*,float*,int,float*,int,int*,float*); ++static void snapps(int,int*,int,float*,float*,float*,int,float*,int,float*,float*,int,float*,float*); ++static void sngets(struct ARPACK_arnoldi_update_vars_s*,int*,int*,float*,float*,float*); ++static void ssortc(const enum ARPACK_which w, const int apply, const int n, float* xreal, float* ximag, float* y); ++static void sgetv0(struct ARPACK_arnoldi_update_vars_s *V, int initv, int n, int j, float* v, int ldv, float* resid, float* rnorm, int* ipntr, float* workd); ++ ++enum ARPACK_neupd_type { ++ REGULAR = 0, ++ SHIFTI, ++ REALPART, ++ IMAGPART ++}; ++ ++ ++void ++ARPACK_sneupd(struct ARPACK_arnoldi_update_vars_s *V, int rvec, int howmny, int* select, ++ float* dr, float* di, float* z, int ldz, float sigmar, float sigmai, ++ float* workev, float* resid, float* v, int ldv, int* ipntr, float* workd, ++ float* workl) ++{ ++ const float eps23 = powf(ulp, 2.0 / 3.0); ++ int ibd, iconj, ih, iheigr, iheigi, ihbds, iuptri, invsub, iri, irr, j, jj; ++ int bounds, k, ldh, ldq, np, numcnv, reord, ritzr, ritzi; ++ int iwork[1] = { 0 }; ++ int ierr = 0, int1 = 1, tmp_int = 0, nconv2 = 0, outncv; ++ float conds, rnorm, sep, temp, temp1, dbl0 = 0.0, dbl1 = 1.0, dblm1 = -1.0; ++ float vl[1] = { 0.0 }; ++ enum ARPACK_neupd_type TYP; ++ ++ if (V->nconv <= 0) { ++ ierr = -14; ++ } else if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv <= V->nev + 1) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if ((V->which > 5) || (V->which < 0)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((rvec) && ((howmny < 0) || (howmny > 2))) { ++ ierr = -13; ++ } else if (howmny == 2) { ++ ierr = -12; // NotImplementedError ++ } ++ ++ if ((V->mode == 1) || (V->mode == 2)) { ++ TYP = REGULAR; ++ } else if ((V->mode == 3) && (sigmai == 0.0)) { ++ TYP = SHIFTI; ++ } else if (V->mode == 3) { ++ TYP = REALPART; ++ } else if (V->mode == 4) { ++ TYP = IMAGPART; ++ } else { ++ ierr = -10; ++ } ++ ++ if ((V->mode == 1) && (V->bmat)) { ierr = -11; } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ return; ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:ncv*ncv) := generated Hessenberg matrix ++ // workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary parts of ritz values ++ // workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds ++ ++ // The following is used and set by SNEUPD . ++ // workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed real part of the Ritz values. ++ // workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed imaginary part of the Ritz values. ++ // workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed error bounds of the Ritz values ++ // workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper quasi-triangular matrix for H ++ // workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the associated matrix representation of the invariant subspace for H. ++ // GRAND total of NCV * ( 3 * NCV + 6 ) locations. ++ ++ ih = ipntr[4]; ++ ritzr = ipntr[5]; ++ ritzi = ipntr[6]; ++ bounds = ipntr[7]; ++ ldh = V->ncv; ++ ldq = V->ncv; ++ iheigr = bounds + ldh; ++ iheigi = iheigr + ldh; ++ ihbds = iheigi + ldh; ++ iuptri = ihbds + ldh; ++ invsub = iuptri + ldh*V->ncv; ++ ipntr[8] = iheigr; ++ ipntr[9] = iheigi; ++ ipntr[10] = ihbds; ++ ipntr[11] = iuptri; ++ ipntr[12] = invsub; ++ ++ // irr points to the REAL part of the Ritz ++ // values computed by _neigh before ++ // exiting _naup2. ++ // iri points to the IMAGINARY part of the ++ // Ritz values computed by _neigh ++ // before exiting _naup2. ++ // ibd points to the Ritz estimates ++ // computed by _neigh before exiting ++ // _naup2. ++ ++ irr = ipntr[13] + (V->ncv)*(V->ncv); ++ iri = irr + V->ncv; ++ ibd = iri + V->ncv; ++ ++ // RNORM is B-norm of the RESID(1:N). ++ rnorm = workl[ih+2]; ++ workl[ih+2] = 0.0; ++ ++ if (rvec) { ++ reord = 0; ++ ++ // Use the temporary bounds array to store indices ++ // These will be used to mark the select array later ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[bounds + j] = j; ++ select[j] = 0; ++ } ++ // 10 ++ ++ // Select the wanted Ritz values. ++ // Sort the Ritz values so that the ++ // wanted ones appear at the tailing ++ // NEV positions of workl(irr) and ++ // workl(iri). Move the corresponding ++ // error estimates in workl(bound) ++ // accordingly. ++ ++ np = V->ncv - V->nev; ++ sngets(V, &V->nev, &np, &workl[irr], &workl[iri], &workl[bounds]); ++ ++ // Record indices of the converged wanted Ritz values ++ // Mark the select array for possible reordering ++ ++ numcnv = 0; ++ for (j = 1; j <= V->ncv; j++) ++ { ++ temp1 = fmaxf(eps23, hypotf(workl[irr + V->ncv - j], workl[iri + V->ncv - j])); ++ ++ jj = (int)workl[bounds + V->ncv - j]; ++ ++ if ((numcnv < V->nconv) && (workl[ibd + jj] <= V->tol*temp1)) ++ { ++ select[jj] = 1; ++ numcnv += 1; ++ if (jj > V->nconv - 1) { reord = 1; } ++ } ++ } ++ // 11 ++ ++ // Check the count (numcnv) of converged Ritz values with ++ // the number (nconv) reported by dnaupd. If these two ++ // are different then there has probably been an error ++ // caused by incorrect passing of the dnaupd data. ++ ++ if (numcnv != V->nconv) ++ { ++ V->info = -15; ++ return; ++ } ++ ++ // Call LAPACK routine dlahqr to compute the real Schur form ++ // of the upper Hessenberg matrix returned by DNAUPD . ++ // Make a copy of the upper Hessenberg matrix. ++ // Initialize the Schur vector matrix Q to the identity. ++ ++ tmp_int = ldh*V->ncv; ++ scopy_(&tmp_int, &workl[ih], &int1, &workl[iuptri], &int1); ++ slaset_("A", &V->ncv, &V->ncv, &dbl0, &dbl1, &workl[invsub], &ldq); ++ slahqr_(&int1, &int1, &V->ncv, &int1, &V->ncv, &workl[iuptri], &ldh, ++ &workl[iheigr], &workl[iheigi], &int1, &V->ncv, &workl[invsub], ++ &ldq, &ierr); ++ scopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ if (ierr != 0) ++ { ++ V->info = -8; ++ return; ++ } ++ ++ if (reord) ++ { ++ strsen_("N", "V", select, &V->ncv, &workl[iuptri], &ldh, &workl[invsub], &ldq, ++ &workl[iheigr], &workl[iheigi], &nconv2, &conds, &sep, &workl[ihbds], ++ &V->ncv, iwork, &int1, &ierr); ++ ++ if (nconv2 < V->nconv) { V->nconv = nconv2; } ++ if (ierr == 1) { ++ V->info = 1; ++ return; ++ } ++ } ++ ++ // Copy the last row of the Schur vector ++ // into workl(ihbds). This will be used ++ // to compute the Ritz estimates of ++ // converged Ritz values. ++ ++ scopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ // Place the computed eigenvalues of H into DR and DI ++ // if a spectral transformation was not used. ++ ++ if (TYP == REGULAR) { ++ scopy_(&V->nconv, &workl[iheigr], &int1, dr, &int1); ++ scopy_(&V->nconv, &workl[iheigi], &int1, di, &int1); ++ } ++ ++ // Compute the QR factorization of the matrix representing ++ // the wanted invariant subspace located in the first NCONV ++ // columns of workl(invsub,ldq). ++ ++ sgeqr2_(&V->ncv, &V->nconv, &workl[invsub], &ldq, workev, &workev[V->ncv], &ierr); ++ ++ // * Postmultiply V by Q using dorm2r . ++ // * Copy the first NCONV columns of VQ into Z. ++ // * Postmultiply Z by R. ++ // The N by NCONV matrix Z is now a matrix representation ++ // of the approximate invariant subspace associated with ++ // the Ritz values in workl(iheigr) and workl(iheigi) ++ // The first NCONV columns of V are now approximate Schur ++ // vectors associated with the real upper quasi-triangular ++ // matrix of order NCONV in workl(iuptri) ++ ++ sorm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[invsub], &ldq, workev, ++ v, &ldv, &workd[V->n], &ierr); ++ ++ slacpy_("A", &V->n, &V->nconv, v, &ldv, z, &ldz); ++ ++ // Perform both a column and row scaling if the ++ // diagonal element of workl(invsub,ldq) is negative ++ // I'm lazy and don't take advantage of the upper ++ // quasi-triangular form of workl(iuptri,ldq) ++ // Note that since Q is orthogonal, R is a diagonal ++ // matrix consisting of plus or minus ones ++ ++ for (j = 0; j < V->nconv; j++) ++ { ++ if (workl[invsub + j*ldq + j] < 0.0) ++ { ++ sscal_(&V->nconv, &dblm1, &workl[iuptri + j], &ldq); ++ sscal_(&V->nconv, &dblm1, &workl[iuptri + j*ldq], &int1); ++ } ++ } ++ // 20 ++ ++ if (howmny == 0) ++ { ++ ++ // Compute the NCONV wanted eigenvectors of T ++ // located in workl(iuptri,ldq). ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ if (j < V->nconv) ++ { ++ select[j] = 1; ++ } else { ++ select[j] = 0; ++ } ++ } ++ // 30 ++ ++ strevc_("R", "S", select, &V->ncv, &workl[iuptri], &ldq, vl, &int1, ++ &workl[invsub], &ldq, &V->ncv, &outncv, workev, &ierr); ++ ++ if (ierr != 0) ++ { ++ V->info = -9; ++ return; ++ } ++ ++ // Scale the returning eigenvectors so that their ++ // Euclidean norms are all one. LAPACK subroutine ++ // dtrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1; ++ ++ iconj = 0; ++ for (j = 0; j < V->nconv; j++) ++ { ++ if (workl[iheigi + j] == 0.0) ++ { ++ ++ // real eigenvalue case ++ ++ temp = 1.0 / snrm2_(&V->ncv, &workl[invsub + j*ldq], &int1); ++ sscal_(&V->ncv, &temp, &workl[invsub + j*ldq], &int1); ++ ++ } else { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ // columns, we further normalize by the ++ // square root of two. ++ ++ if (iconj == 0) ++ { ++ temp = 1.0 / hypotf(snrm2_(&V->ncv, &workl[invsub + j*ldq], &int1), ++ snrm2_(&V->ncv, &workl[invsub + (j+1)*ldq], &int1)); ++ sscal_(&V->ncv, &temp, &workl[invsub + j*ldq], &int1); ++ sscal_(&V->ncv, &temp, &workl[invsub + (j+1)*ldq], &int1); ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 40 ++ ++ sgemv_("T", &V->ncv, &V->nconv, &dbl1, &workl[invsub], &ldq, &workl[ihbds], &int1, &dbl0, workev, &int1); ++ ++ iconj = 0; ++ for (j = 0; j < V->nconv; j++) ++ { ++ if (workl[iheigi + j] != 0.0) ++ { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ ++ if (iconj == 0) ++ { ++ workev[j] = hypotf(workev[j], workev[j+1]); ++ workev[j+1] = workev[j]; ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 45 ++ ++ // Copy Ritz estimates into workl(ihbds) ++ ++ scopy_(&V->nconv, workev, &int1, &workl[ihbds], &int1); ++ ++ // Compute the QR factorization of the eigenvector matrix ++ // associated with leading portion of T in the first NCONV ++ // columns of workl(invsub,ldq). ++ ++ sgeqr2_(&V->ncv, &V->nconv, &workl[invsub], &ldq, workev, &workev[V->ncv], &ierr); ++ ++ // * Postmultiply Z by Q. ++ // * Postmultiply Z by R. ++ // The N by NCONV matrix Z is now contains the ++ // Ritz vectors associated with the Ritz values ++ // in workl(iheigr) and workl(iheigi). ++ ++ sorm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[invsub], &ldq, ++ workev, z, &ldz, &workd[V->n], &ierr); ++ ++ strmm_("R", "U", "N", "N", &V->n, &V->nconv, &dbl1, &workl[invsub], &ldq, z, &ldz); ++ ++ } ++ ++ } else { ++ ++ // An approximate invariant subspace is not needed. ++ // Place the Ritz values computed DNAUPD into DR and DI ++ ++ scopy_(&V->nconv, &workl[ritzr], &int1, dr, &int1); ++ scopy_(&V->nconv, &workl[ritzi], &int1, di, &int1); ++ scopy_(&V->nconv, &workl[ritzr], &int1, &workl[iheigr], &int1); ++ scopy_(&V->nconv, &workl[ritzi], &int1, &workl[iheigi], &int1); ++ scopy_(&V->nconv, &workl[bounds], &int1, &workl[ihbds], &int1); ++ } ++ ++ // Transform the Ritz values and possibly vectors ++ // and corresponding error bounds of OP to those ++ // of A*x = lambda*B*x. ++ ++ if (TYP == REGULAR) ++ { ++ if (rvec) ++ { ++ sscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ } else { ++ ++ // A spectral transformation was used. ++ // * Determine the Ritz estimates of the ++ // Ritz values in the original system. ++ ++ if (TYP == SHIFTI) ++ { ++ if (rvec) ++ { ++ sscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ ++ for (k = 0; k < V->ncv; k++) ++ { ++ temp = hypotf(workl[iheigr+k], workl[iheigi+k]); ++ workl[ihbds+k] = fabsf(workl[ihbds+k]) / temp / temp; ++ } ++ // 50 ++ ++ } ++ ++ // * Transform the Ritz values back to the original system. ++ // For TYPE = 'SHIFTI' the transformation is ++ // lambda = 1/theta + sigma ++ // For TYPE = 'REALPT' or 'IMAGPT' the user must from ++ // Rayleigh quotients or a projection. See remark 3 above. ++ // NOTES: ++ // *The Ritz vectors are not affected by the transformation. ++ ++ if (TYP == SHIFTI) ++ { ++ for (k = 0; k < V->ncv; k++) ++ { ++ temp = hypotf(workl[iheigr+k], workl[iheigi+k]); ++ workl[iheigr+k] = workl[iheigr+k] / temp / temp + sigmar; ++ workl[iheigi+k] = -workl[iheigi+k] / temp / temp + sigmai; ++ } ++ // 80 ++ ++ scopy_(&V->nconv, &workl[iheigr], &int1, dr, &int1); ++ scopy_(&V->nconv, &workl[iheigi], &int1, di, &int1); ++ ++ } else if ((TYP == REALPART) || (TYP == IMAGPART)) { ++ scopy_(&V->nconv, &workl[iheigr], &int1, dr, &int1); ++ scopy_(&V->nconv, &workl[iheigi], &int1, di, &int1); ++ } ++ } ++ ++ // Eigenvector Purification step. Formally perform ++ // one of inverse subspace iteration. Only used ++ // for MODE = 2. ++ ++ if ((rvec) && (howmny == 0) && (TYP == SHIFTI)) ++ { ++ ++ // Purify the computed Ritz vectors by adding a ++ // little bit of the residual vector: ++ // T ++ // resid(:)*( e s ) / theta ++ // NCV ++ // where H s = s theta. Remember that when theta ++ // has nonzero imaginary part, the corresponding ++ // Ritz vector is stored across two columns of Z. ++ ++ iconj = 0; ++ for (j = 0; j < V->nconv; j++) ++ { ++ if ((workl[iheigi+j] == 0.0) && (workl[iheigr+j] != 0.0)) ++ { ++ workev[j] = workl[invsub + j*ldq + V->ncv] / workl[iheigr+j]; ++ } else if (iconj == 0) { ++ ++ temp = hypotf(workl[iheigr+j], workl[iheigi+j]); ++ if (temp != 0.0) ++ { ++ workev[j] = (workl[invsub + j*ldq + V->ncv]*workl[iheigr+j] + ++ workl[invsub + (j+1)*ldq + V->ncv]*workl[iheigi+j] ++ ) / temp / temp; ++ workev[j+1] = (workl[invsub + (j+1)*ldq + V->ncv]*workl[iheigr+j] - ++ workl[invsub + j*ldq + V->ncv]*workl[iheigi+j] ++ ) / temp / temp; ++ } ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ // 110 ++ ++ // Perform a rank one update to Z and ++ // purify all the Ritz vectors together. ++ ++ sger_(&V->n, &V->nconv, &dbl1, resid, &int1, workev, &int1, z, &ldz); ++ } ++ ++ return; ++} ++ ++void ++ARPACK_snaupd(struct ARPACK_arnoldi_update_vars_s *V, float* resid, float* v, ++ int ldv, int* ipntr, float* workd, float* workl) ++{ ++ int bounds, ih, iq, iw, j, ldh, ldq, next, iritzi, iritzr; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // perform basic checks ++ if (V->n <= 0) { ++ V->info = -1; ++ } else if (V->nev <= 0) { ++ V->info = -2; ++ } else if ((V->ncv < V->nev + 1) || (V->ncv > V->n)) { ++ V->info = -3; ++ } else if (V->maxiter <= 0) { ++ V->info = -4; ++ } else if ((V->which < 0) || (V->which > 5)) { ++ V->info = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ V->info = -6; ++ } else if ((V->mode < 1) || (V->mode > 4)) { ++ V->info = -10; ++ } else if ((V->mode == 1) && (V->bmat == 1)) { ++ V->info = -11; ++ } else if ((V->shift != 0) && (V->shift != 1)) { ++ V->info = -12; ++ } ++ ++ if (V->info < 0) { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ if (V->tol <= 0.0) { ++ V->tol = ulp; ++ } ++ V->np = V->ncv - V->nev; ++ ++ for (j = 0; j < 3 * (V->ncv)*(V->ncv) + 6*(V->ncv); j++) ++ { ++ workl[j] = 0.0; ++ } ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // ++ // workl[0:ncv*ncv] := generated Hessenberg matrix ++ // workl[ncv**2:ncv**2+2*ncv] := ritz.real and ritz.imag values ++ // workl[ncv**2+2*ncv:ncv*ncv+3*ncv] := error bounds ++ // workl[ncv**2+3*ncv+1:2*ncv*ncv+3*ncv] := rotation matrix Q ++ // workl[2*ncv**2+3*ncv:3*ncv*ncv+6*ncv] := workspace ++ // ++ // The final workspace is needed by subroutine dneigh called ++ // by dnaup2 . Subroutine dneigh calls LAPACK routines for ++ // calculating eigenvalues and the last row of the eigenvector ++ // matrix. ++ ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ih = 0; ++ iritzr = ih + ldh*V->ncv; ++ iritzi = iritzr + V->ncv; ++ bounds = iritzi + V->ncv; ++ iq = bounds + V->ncv; ++ iw = iq + ldq*V->ncv; ++ next = iw + (V->ncv*V->ncv) + 3*V->ncv; ++ ++ ipntr[3] = next; ++ ipntr[4] = ih; ++ ipntr[5] = iritzr; ++ ipntr[6] = iritzi; ++ ipntr[7] = bounds; ++ ipntr[13] = iw; ++ ++ // Carry out the Implicitly restarted Arnoldi Iteration. ++ ++ snaup2(V, resid, v, ldv, &workl[ih], ldh, &workl[iritzr], &workl[iritzi], &workl[bounds], &workl[iq], ldq, &workl[iw], ipntr, workd); ++ ++ // ido != DONE implies use of reverse communication ++ // to compute operations involving OP or shifts. ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ V->nconv = V->np; ++ // iparam(9) = nopx ++ // iparam(10) = nbx ++ // iparam(11) = nrorth ++ ++ if (V->info < 0) { return; } ++ if (V->info == 2) { V->info = 3; } ++ ++ return; ++} ++ ++void ++snaup2(struct ARPACK_arnoldi_update_vars_s *V, float* resid, float* v, int ldv, ++ float* h, int ldh, float* ritzr, float* ritzi, float* bounds, ++ float* q, int ldq, float* workl, int* ipntr, float* workd) ++{ ++ enum ARPACK_which temp_which; ++ int int1 = 1, j, tmp_int; ++ const float eps23 = powf(ulp, 2.0 / 3.0); ++ float temp = 0.0; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->aup2_nev0 = V->nev; ++ V->aup2_np0 = V->np; ++ ++ // kplusp is the bound on the largest ++ // Lanczos factorization built. ++ // nconv is the current number of ++ // "converged" eigenvlues. ++ // iter is the counter on the current ++ // iteration step. ++ ++ V->aup2_kplusp = V->nev + V->np; ++ V->nconv = 0; ++ V->aup2_iter = 0; ++ ++ // Set flags for computing the first NEV ++ // steps of the Arnoldi factorization. ++ ++ V->aup2_getv0 = 1; ++ V->aup2_update = 0; ++ V->aup2_ushift = 0; ++ V->aup2_cnorm = 0; ++ ++ if (V->info != 0) ++ { ++ ++ // User provides the initial residual vector. ++ ++ V->aup2_initv = 1; ++ V->info = 0; ++ } else { ++ V->aup2_initv = 0; ++ } ++ } ++ ++ // Get a possibly random starting vector and ++ // force it into the range of the operator OP. ++ ++ if (V->aup2_getv0) ++ { ++ V->getv0_itry = 1; ++ sgetv0(V, V->aup2_initv, V->n, 0, v, ldv, resid, &V->aup2_rnorm, ipntr, workd); ++ if (V->ido != ido_DONE) { return; } ++ if (V->aup2_rnorm == 0.0) ++ { ++ V->info = -9; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_getv0 = 0; ++ V->ido = ido_FIRST; ++ } ++ ++ // Back from reverse communication : ++ // continue with update step ++ ++ if (V->aup2_update) { goto LINE20; } ++ ++ // Back from computing user specified shifts ++ ++ if (V->aup2_ushift) { goto LINE50; } ++ ++ // Back from computing residual norm ++ // at the end of the current iteration ++ ++ if (V->aup2_cnorm) { goto LINE100; } ++ ++ // Compute the first NEV steps of the Arnoldi factorization ++ ++ snaitr(V, 0, V->nev, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // ++ // M A I N ARNOLDI I T E R A T I O N L O O P ++ // Each iteration implicitly restarts the Arnoldi ++ // factorization in place. ++ // ++ ++LINE1000: ++ V->aup2_iter += 1; ++ ++ // Compute NP additional steps of the Arnoldi factorization. ++ // Adjust NP since NEV might have been updated by last call ++ // to the shift application routine dnapps . ++ ++ V->np = V->aup2_kplusp - V->nev; ++ ++ // Compute NP additional steps of the Arnoldi factorization. ++ ++ V->ido = ido_FIRST; ++ ++LINE20: ++ V->aup2_update = 1; ++ ++ snaitr(V, V->nev, V->np, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_update = 0; ++ ++ // Compute the eigenvalues and corresponding error bounds ++ // of the current upper Hessenberg matrix. ++ ++ sneigh(&V->aup2_rnorm, V->aup2_kplusp, h, ldh, ritzr, ritzi, bounds, q, ldq, workl, &V->info); ++ ++ if (V->info != 0) ++ { ++ V->info = -8; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Make a copy of eigenvalues and corresponding error ++ // bounds obtained from dneigh. ++ ++ tmp_int = V->aup2_kplusp * V->aup2_kplusp; ++ scopy_(&V->aup2_kplusp, ritzr, &int1, &workl[tmp_int], &int1); ++ tmp_int += V->aup2_kplusp; ++ scopy_(&V->aup2_kplusp, ritzi, &int1, &workl[tmp_int], &int1); ++ tmp_int += V->aup2_kplusp; ++ scopy_(&V->aup2_kplusp, bounds, &int1, &workl[tmp_int], &int1); ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The wanted part of the spectrum and corresponding ++ // error bounds are in the last NEV loc. of RITZR, ++ // RITZI and BOUNDS respectively. The variables NEV ++ // and NP may be updated if the NEV-th wanted Ritz ++ // value has a non zero imaginary part. In this case ++ // NEV is increased by one and NP decreased by one. ++ // NOTE: The last two arguments of dngets are no ++ // longer used as of version 2.1. ++ ++ V->nev = V->aup2_nev0; ++ V->np = V->aup2_np0; ++ V->aup2_numcnv = V->nev; ++ ++ sngets(V, &V->nev, &V->np, ritzr, ritzi, bounds); ++ ++ if (V->nev == V->aup2_nev0 + 1) { V->aup2_numcnv = V->aup2_nev0 + 1;} ++ ++ // Convergence test. ++ ++ scopy_(&V->nev, &bounds[V->np], &int1, &workl[2*V->np], &int1); ++ snconv(V->nev, &ritzr[V->np], &ritzi[V->np], &workl[2*V->np], V->tol, &V->nconv); ++ ++ // Count the number of unwanted Ritz values that have zero ++ // Ritz estimates. If any Ritz estimates are equal to zero ++ // then a leading block of H of order equal to at least ++ // the number of Ritz values with zero Ritz estimates has ++ // split off. None of these Ritz values may be removed by ++ // shifting. Decrease NP the number of shifts to apply. If ++ // no shifts may be applied, then prepare to exit ++ ++ // We are modifying V->np hence the temporary variable. ++ int nptemp = V->np; ++ ++ for (j = 0; j < nptemp; j++) ++ { ++ if (bounds[j] == 0.0) ++ { ++ V->np -= 1; ++ V->nev += 1; ++ } ++ } ++ // 30 ++ ++ if ((V->nconv >= V->aup2_numcnv) || (V->aup2_iter > V->maxiter) || (V->np == 0)) ++ { ++ ++ // Prepare to exit. Put the converged Ritz values ++ // and corresponding bounds in RITZ(1:NCONV) and ++ // BOUNDS(1:NCONV) respectively. Then sort. Be ++ // careful when NCONV > NP ++ ++ // Use h( 3,1 ) as storage to communicate ++ // rnorm to _neupd if needed ++ ++ h[2] = V->aup2_rnorm; ++ ++ // To be consistent with dngets , we first do a ++ // pre-processing sort in order to keep complex ++ // conjugate pairs together. This is similar ++ // to the pre-processing sort used in dngets ++ // except that the sort is done in the opposite ++ // order. ++ ++ // Translation note: Is this all because ARPACK did not have complex sort? ++ ++ if (V->which == which_LM) { temp_which = which_SR; } ++ if (V->which == which_SM) { temp_which = which_LR; } ++ if (V->which == which_LR) { temp_which = which_SM; } ++ if (V->which == which_SR) { temp_which = which_LM; } ++ if (V->which == which_LI) { temp_which = which_SM; } ++ if (V->which == which_SI) { temp_which = which_LM; } ++ ++ ssortc(temp_which, 1, V->aup2_kplusp, ritzr, ritzi, bounds); ++ ++ if (V->which == which_LM) { temp_which = which_SM; } ++ if (V->which == which_SM) { temp_which = which_LM; } ++ if (V->which == which_LR) { temp_which = which_SR; } ++ if (V->which == which_SR) { temp_which = which_LR; } ++ if (V->which == which_LI) { temp_which = which_SI; } ++ if (V->which == which_SI) { temp_which = which_LI; } ++ ++ ssortc(temp_which, 1, V->aup2_kplusp, ritzr, ritzi, bounds); ++ ++ // Scale the Ritz estimate of each Ritz value ++ // by 1 / max(eps23,magnitude of the Ritz value). ++ ++ for (j = 0; j < V->aup2_numcnv; j++) ++ { ++ temp = fmaxf(eps23, hypotf(ritzr[j], ritzi[j])); ++ bounds[j] = bounds[j] / temp; ++ } ++ // 35 ++ ++ // Sort the Ritz values according to the scaled Ritz ++ // estimates. This will push all the converged ones ++ // towards the front of ritzr, ritzi, bounds ++ // (in the case when NCONV < NEV.) ++ ++ temp_which = which_LR; ++ ssortc(temp_which, 1, V->aup2_numcnv, bounds, ritzr, ritzi); ++ ++ // Scale the Ritz estimate back to its original ++ // value. ++ ++ for (j = 0; j < V->aup2_numcnv; j++) ++ { ++ temp = fmaxf(eps23, hypotf(ritzr[j], ritzi[j])); ++ bounds[j] = bounds[j] * temp; ++ } ++ // 40 ++ ++ // Sort the converged Ritz values again so that ++ // the "threshold" value appears at the front of ++ // ritzr, ritzi and bound. ++ ++ ssortc(V->which, 1, V->nconv, ritzr, ritzi, bounds); ++ ++ if ((V->aup2_iter > V->maxiter) && (V->nconv < V->aup2_numcnv)) ++ { ++ ++ // Max iterations have been exceeded. ++ ++ V->info = 1; ++ } ++ ++ if ((V->np == 0) && (V->nconv < V->aup2_numcnv)) ++ { ++ ++ // No shifts to apply. ++ ++ V->info = 2; ++ } ++ ++ V->np = V->nconv; ++ V->iter = V->aup2_iter; ++ V->nev = V->aup2_numcnv; ++ V->ido = ido_DONE; ++ return; ++ ++ } else if ((V->nconv < V->aup2_numcnv) && (V->shift)) { ++ ++ // Do not have all the requested eigenvalues yet. ++ // To prevent possible stagnation, adjust the size ++ // of NEV. ++ ++ int nevbef = V->nev; ++ V->nev += (V->nconv > (V->np / 2) ? (V->np / 2) : V->nconv); ++ if ((V->nev == 1) && (V->aup2_kplusp >= 6)) { ++ V->nev = V->aup2_kplusp / 2; ++ } else if ((V->nev == 1) && (V->aup2_kplusp > 3)) { ++ V->nev = 2; ++ } ++ ++ // SciPy Fix ++ // We must keep nev below this value, as otherwise we can get ++ // np == 0 (note that dngets below can bump nev by 1). If np == 0, ++ // the next call to `dnaitr` will write out-of-bounds. ++ ++ if (V->nev > (V->aup2_kplusp - 2)) { ++ V->nev = V->aup2_kplusp - 2; ++ } ++ // SciPy Fix End ++ ++ V->np = V->aup2_kplusp - V->nev; ++ ++ if (nevbef < V->nev) { ++ sngets(V, &V->nev, &V->np, ritzr, ritzi, bounds); ++ } ++ ++ } ++ ++ if (V->shift == 0) ++ { ++ ++ // User specified shifts: reverse communication to ++ // compute the shifts. They are returned in the first ++ // 2*NP locations of WORKL. ++ ++ V->aup2_ushift = 1; ++ V->ido = ido_USER_SHIFT; ++ return; ++ } ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // User specified shifts are returned ++ // in WORKL(1:2*NP) ++ ++ V->aup2_ushift = 0; ++ ++ if (V->shift == 0) ++ { ++ ++ // Move the NP shifts from WORKL to ++ // RITZR, RITZI to free up WORKL ++ // for non-exact shift case. ++ ++ scopy_(&V->np, workl, &int1, ritzr, &int1); ++ scopy_(&V->np, &workl[V->np], &int1, ritzi, &int1); ++ } ++ ++ // Apply the NP implicit shifts by QR bulge chasing. ++ // Each shift is applied to the whole upper Hessenberg ++ // matrix H. ++ // The first 2*N locations of WORKD are used as workspace. ++ ++ snapps(V->n, &V->nev, V->np, ritzr, ritzi, v, ldv, h, ldh, resid, q, ldq, workl, workd); ++ ++ // Compute the B-norm of the updated residual. ++ // Keep B*RESID in WORKD(1:N) to be used in ++ // the first step of the next call to dnaitr . ++ ++ V->aup2_cnorm = 1; ++ if (V->bmat) ++ { ++ scopy_(&V->n, resid, &int1, &workd[V->n], &int1); ++ ipntr[0] = V->n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*RESID ++ ++ return; ++ } else { ++ scopy_(&V->n, resid, &int1, workd, &int1); ++ } ++ ++LINE100: ++ ++ // Back from reverse communication; ++ // WORKD(1:N) := B*RESID ++ ++ if (V->bmat) ++ { ++ V->aup2_rnorm = sdot_(&V->n, resid, &int1, workd, &int1); ++ V->aup2_rnorm = sqrtf(fabsf(V->aup2_rnorm)); ++ } else { ++ V->aup2_rnorm = snrm2_(&V->n, resid, &int1); ++ } ++ V->aup2_cnorm = 0; ++ ++ goto LINE1000; ++ ++ // ++ // E N D O F M A I N I T E R A T I O N L O O P ++ // ++ ++} ++ ++void ++snconv(int n, float* ritzr, float* ritzi, float* bounds, const float tol, int* nconv) ++{ ++ const float eps23 = powf(ulp, 2.0 / 3.0); ++ float temp; ++ ++ *nconv = 0; ++ for (int i = 0; i < n; i++) ++ { ++ temp = fmaxf(eps23, hypotf(ritzr[i], ritzi[i])); ++ if (bounds[i] <= tol*temp) ++ { ++ *nconv += 1; ++ } ++ } ++ ++ return; ++} ++ ++void ++sneigh(float* rnorm, int n, float* h, int ldh, float* ritzr, float* ritzi, ++ float* bounds, float* q, int ldq, float* workl, int* ierr) ++{ ++ int select[1] = { 0 }; ++ int i, iconj, int1 = 1, j; ++ float dbl1 = 1.0, dbl0 = 0.0, temp, tmp_dbl, vl[1] = { 0.0 }; ++ ++ // 1. Compute the eigenvalues, the last components of the ++ // corresponding Schur vectors and the full Schur form T ++ // of the current upper Hessenberg matrix H. ++ // dlahqr returns the full Schur form of H in WORKL(1:N**2) ++ // and the last components of the Schur vectors in BOUNDS. ++ ++ slacpy_("A", &n, &n, h, &ldh, workl, &n); ++ for (j = 0; j < n-1; j++) ++ { ++ bounds[j] = 0.0; ++ } ++ bounds[n-1] = 1.0; ++ slahqr_(&int1, &int1, &n, &int1, &n, workl, &n, ritzr, ritzi, &int1, &int1, bounds, &int1, ierr); ++ ++ if (*ierr != 0) { return; } ++ ++ // 2. Compute the eigenvectors of the full Schur form T and ++ // apply the last components of the Schur vectors to get ++ // the last components of the corresponding eigenvectors. ++ // Remember that if the i-th and (i+1)-st eigenvalues are ++ // complex conjugate pairs, then the real & imaginary part ++ // of the eigenvector components are split across adjacent ++ // columns of Q. ++ ++ strevc_("R", "A", select, &n, workl, &n, vl, &n, q, &ldq, &n, &n, &workl[n*n], ierr); ++ if (*ierr != 0) { return; } ++ ++ // Scale the returning eigenvectors so that their ++ // euclidean norms are all one. LAPACK subroutine ++ // dtrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1; here the magnitude of a complex ++ // number (x,y) is taken to be |x| + |y|. ++ ++ iconj = 0; ++ for (i = 0; i < n; i++) ++ { ++ if (fabsf(ritzi[i]) == 0.0) ++ { ++ ++ // Real eigenvalue case ++ ++ temp = snrm2_(&n, &q[ldq*i], &int1); ++ tmp_dbl = 1.0 / temp; ++ sscal_(&n, &tmp_dbl, &q[ldq*i], &int1); ++ ++ } else { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ // columns, we further normalize by the ++ // square root of two. ++ ++ if (iconj == 0) ++ { ++ temp = hypotf(snrm2_(&n, &q[ldq*i], &int1), ++ snrm2_(&n, &q[ldq*(i+1)], &int1)); ++ tmp_dbl = 1.0 / temp; ++ sscal_(&n, &tmp_dbl, &q[ldq*i], &int1); ++ sscal_(&n, &tmp_dbl, &q[ldq*(i+1)], &int1); ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 10 ++ ++ sgemv_("T", &n, &n, &dbl1, q, &ldq, bounds, &int1, &dbl0, workl, &int1); ++ ++ // Compute the Ritz estimates ++ ++ iconj = 0; ++ for (i = 0; i < n; i++) ++ { ++ if (fabsf(ritzi[i]) == 0.0) ++ { ++ ++ // Real eigenvalue case ++ ++ bounds[i] = *rnorm * fabsf(workl[i]); ++ ++ } else { ++ ++ // Complex conjugate pair case. Note that ++ // since the real and imaginary part of ++ // the eigenvector are stored in consecutive ++ // columns, we need to take the magnitude ++ // of the last components of the two vectors ++ ++ if (iconj == 0) ++ { ++ bounds[i] = *rnorm * hypotf(workl[i], workl[i+1]); ++ bounds[i+1] = bounds[i]; ++ iconj = 1; ++ } else { ++ iconj = 0; ++ } ++ } ++ } ++ // 20 ++ ++ return; ++} ++ ++void ++snaitr(struct ARPACK_arnoldi_update_vars_s *V, int k, int np, float* resid, float* rnorm, ++ float* v, int ldv, float* h, int ldh, int* ipntr, float* workd) ++{ ++ int i = 0, infol, ipj, irj, ivj, jj, n, tmp_int; ++ float smlnum = unfl * ( V->n / ulp); ++ const float sq2o2 = sqrtf(2.0) / 2.0; ++ ++ int int1 = 1; ++ float dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0, temp1, tst1; ++ ++ n = V->n; // n is constant, this is just for typing convenience ++ ipj = 0; ++ irj = ipj + n; ++ ivj = irj + n; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // Initial call to this routine ++ ++ V->aitr_j = k; ++ V->info = 0; ++ V->aitr_step3 = 0; ++ V->aitr_step4 = 0; ++ V->aitr_orth1 = 0; ++ V->aitr_orth2 = 0; ++ V->aitr_restart = 0; ++ } ++ ++ // When in reverse communication mode one of: ++ // STEP3, STEP4, ORTH1, ORTH2, RSTART ++ // will be .true. when .... ++ // STEP3: return from computing OP*v_{j}. ++ // STEP4: return from computing B-norm of OP*v_{j} ++ // ORTH1: return from computing B-norm of r_{j+1} ++ // ORTH2: return from computing B-norm of correction to the residual vector. ++ // RSTART: return from OP computations needed by sgetv0. ++ ++ if (V->aitr_step3) { goto LINE50; } ++ if (V->aitr_step4) { goto LINE60; } ++ if (V->aitr_orth1) { goto LINE70; } ++ if (V->aitr_orth2) { goto LINE90; } ++ if (V->aitr_restart) { goto LINE30; } ++ ++ // Else this is the first step ++ ++ // ++ // A R N O L D I I T E R A T I O N L O O P ++ // ++ // Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) ++ ++LINE1000: ++ ++ // STEP 1: Check if the B norm of j-th residual ++ // vector is zero. Equivalent to determining whether ++ // an exact j-step Arnoldi factorization is present. ++ ++ V->aitr_betaj = *rnorm; ++ ++ if (*rnorm > 0.0) { goto LINE40; } ++ ++ // Invariant subspace found, generate a new starting ++ // vector which is orthogonal to the current Arnoldi ++ // basis and continue the iteration. ++ ++ V->aitr_betaj = 0.0; ++ V->getv0_itry = 1; ++ ++LINE20: ++ V->aitr_restart = 1; ++ V->ido = ido_FIRST; ++ ++LINE30: ++ ++ // If in reverse communication mode and aitr_restart = 1, flow returns here. ++ ++ sgetv0(V, 0, n, V->aitr_j, v, ldv, resid, rnorm, ipntr, workd); ++ ++ if (V->ido != ido_DONE) { return; } ++ V->aitr_ierr = V->info; ++ if (V->aitr_ierr < 0) ++ { ++ V->getv0_itry += 1; ++ if (V->getv0_itry <= 3) { goto LINE20; } ++ ++ // Give up after several restart attempts. ++ // Set INFO to the size of the invariant subspace ++ // which spans OP and exit. ++ ++ V->info = V->aitr_j; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++LINE40: ++ ++ // STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm ++ // Note that p_{j} = B*r_{j-1}. In order to avoid overflow ++ // when reciprocating a small RNORM, test against lower ++ // machine bound. ++ ++ scopy_(&n, resid, &int1, &v[ldv*(V->aitr_j)], &int1); ++ if (*rnorm >= unfl) ++ { ++ temp1 = 1.0 / *rnorm; ++ sscal_(&n, &temp1, &v[ldv*(V->aitr_j)], &int1); ++ sscal_(&n, &temp1, &workd[ipj], &int1); ++ } else { ++ slascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &v[ldv*(V->aitr_j)], &n, &infol); ++ slascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &workd[ipj], &n, &infol); ++ } ++ ++ // STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} ++ // Note that this is not quite yet r_{j}. See STEP 4 ++ ++ V->aitr_step3 = 1; ++ scopy_(&n, &v[ldv*(V->aitr_j)], &int1, &workd[ivj], &int1); ++ ipntr[0] = ivj; ++ ipntr[1] = irj; ++ ipntr[2] = ipj; ++ V->ido = ido_OPX; ++ ++ // Exit in order to compute OP*v_{j} ++ ++ return; ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // WORKD(IRJ:IRJ+N-1) := OP*v_{j} ++ // if step3 = .true. ++ ++ V->aitr_step3 = 0; ++ ++ // Put another copy of OP*v_{j} into RESID. ++ ++ scopy_(&n, &workd[irj], &int1, resid, &int1); ++ ++ // STEP 4: Finish extending the Arnoldi ++ // factorization to length j. ++ ++ if (V->bmat) ++ { ++ V->aitr_step4 = 1; ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*OP*v_{j} ++ ++ return; ++ } else { ++ scopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE60: ++ ++ // Back from reverse communication; ++ // WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} ++ // if step4 = .true. ++ ++ V->aitr_step4 = 0; ++ ++ // The following is needed for STEP 5. ++ // Compute the B-norm of OP*v_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_wnorm = sdot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_wnorm = sqrtf(fabsf(V->aitr_wnorm)); ++ } else { ++ V->aitr_wnorm = snrm2_(&n, resid, &int1); ++ } ++ ++ // Compute the j-th residual corresponding ++ // to the j step factorization. ++ // Use Classical Gram Schmidt and compute: ++ // w_{j} <- V_{j}^T * B * OP * v_{j} ++ // r_{j} <- OP*v_{j} - V_{j} * w_{j} ++ ++ // Compute the j Fourier coefficients w_{j} ++ // WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. ++ tmp_int = V->aitr_j + 1; ++ sgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &h[ldh*(V->aitr_j)], &int1); ++ ++ // Orthogonalize r_{j} against V_{j}. ++ // RESID contains OP*v_{j}. See STEP 3. ++ ++ sgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &h[ldh*(V->aitr_j)], &int1, &dbl1, resid, &int1); ++ ++ if (V->aitr_j > 0) { h[V->aitr_j + ldh*(V->aitr_j-1)] = V->aitr_betaj; } ++ ++ V->aitr_orth1 = 1; ++ if (V->bmat) ++ { ++ scopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j} ++ ++ return; ++ } else { ++ scopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE70: ++ ++ // Back from reverse communication if ORTH1 = .true. ++ // WORKD(IPJ:IPJ+N-1) := B*r_{j}. ++ ++ V->aitr_orth1 = 0; ++ ++ // Compute the B-norm of r_{j}. ++ ++ if (V->bmat) ++ { ++ *rnorm = sdot_(&n, resid, &int1, &workd[ipj], &int1); ++ *rnorm = sqrtf(fabsf(*rnorm)); ++ } else { ++ *rnorm = snrm2_(&n, resid, &int1); ++ } ++ ++ // STEP 5: Re-orthogonalization / Iterative refinement phase ++ // Maximum NITER_ITREF tries. ++ // ++ // s = V_{j}^T * B * r_{j} ++ // r_{j} = r_{j} - V_{j}*s ++ // alphaj = alphaj + s_{j} ++ // ++ // The stopping criteria used for iterative refinement is ++ // discussed in Parlett's book SEP, page 107 and in Gragg & ++ // Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. ++ // Determine if we need to correct the residual. The goal is ++ // to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || ++ // The following test determines whether the sine of the ++ // angle between OP*x and the computed residual is less ++ // than or equal to 0.7071. ++ ++ if (*rnorm > sq2o2*V->aitr_wnorm) { goto LINE100; } ++ V->aitr_iter = 0; ++ ++ // Enter the Iterative refinement phase. If further ++ // refinement is necessary, loop back here. The loop ++ // variable is ITER. Perform a step of Classical ++ // Gram-Schmidt using all the Arnoldi vectors V_{j} ++ ++LINE80: ++ ++ // Compute V_{j}^T * B * r_{j}. ++ // WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). ++ tmp_int = V->aitr_j + 1; ++ sgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &workd[irj], &int1); ++ ++ // Compute the correction to the residual: ++ // r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). ++ // The correction to H is v(:,1:J)*H(1:J,1:J) ++ // + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. ++ ++ sgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &workd[irj], &int1, &dbl1, resid, &int1); ++ saxpy_(&tmp_int, &dbl1, &workd[irj], &int1, &h[ldh*(V->aitr_j)], &int1); ++ ++ V->aitr_orth2 = 1; ++ ++ if (V->bmat) ++ { ++ scopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j}. ++ // r_{j} is the corrected residual. ++ ++ return; ++ } else { ++ scopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE90: ++ ++ // Back from reverse communication if ORTH2 = .true. ++ ++ // Compute the B-norm of the corrected residual r_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_rnorm1 = sdot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_rnorm1 = sqrtf(fabsf(V->aitr_rnorm1)); ++ } else { ++ V->aitr_rnorm1 = snrm2_(&n, resid, &int1); ++ } ++ ++ // Determine if we need to perform another ++ // step of re-orthogonalization. ++ ++ if (V->aitr_rnorm1 > sq2o2*(*rnorm)) ++ { ++ ++ // No need for further refinement. ++ // The cosine of the angle between the ++ // corrected residual vector and the old ++ // residual vector is greater than 0.717 ++ // In other words the corrected residual ++ // and the old residual vector share an ++ // angle of less than arcCOS(0.717) ++ ++ *rnorm = V->aitr_rnorm1; ++ ++ } else { ++ ++ // Another step of iterative refinement step ++ // is required. ++ ++ *rnorm = V->aitr_rnorm1; ++ V->aitr_iter += 1; ++ if (V->aitr_iter < 2) { goto LINE80; } ++ ++ // Otherwise RESID is numerically in the span of V ++ ++ for (jj = 0; jj < n; jj++) ++ { ++ resid[jj] = 0.0; ++ } ++ *rnorm = 0.0; ++ } ++ ++ // Branch here directly if iterative refinement ++ // wasn't necessary or after at most NITER_REF ++ // steps of iterative refinement. ++ ++LINE100: ++ ++ V->aitr_restart = 0; ++ V->aitr_orth2 = 0; ++ ++ // STEP 6: Update j = j+1; Continue ++ ++ V->aitr_j += 1; ++ if (V->aitr_j >= k + np) ++ { ++ V->ido = ido_DONE; ++ for (i = (k > 0 ? k-1 : k); i < k + np - 1; i++) ++ { ++ ++ // Check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine dlahqr ++ ++ tst1 = fabsf(h[i + ldh*i]) + fabsf(h[i+1 + ldh*(i+1)]); ++ if (tst1 == 0.0) ++ { ++ tmp_int = k + np; ++ tst1 = slanhs_("1", &tmp_int, h, &ldh, &workd[n]); ++ } ++ if (fabsf(h[i+1 + ldh*i]) <= fmaxf(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = 0.0; ++ } ++ } ++ // 110 ++ return; ++ } ++ goto LINE1000; ++ ++} ++ ++ ++void ++snapps(int n, int* kev, int np, float* shiftr, float* shifti, float* v, ++ int ldv, float* h, int ldh, float* resid, float* q, int ldq, float* workl, ++ float* workd) ++{ ++ int cconj; ++ int i, ir, j, jj, int1 = 1, istart, iend = 0, nr, tmp_int; ++ int kplusp = *kev + np; ++ float smlnum = unfl * ( n / ulp); ++ float c, f, g, h11, h21, h12, h22, h32, s, sigmar, sigmai, r, t, tau, tst1; ++ float dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0; ++ float u[3] = { 0.0 }; ++ ++ // Initialize Q to the identity to accumulate ++ // the rotations and reflections ++ slaset_("A", &kplusp, &kplusp, &dbl0, &dbl1, q, &ldq); ++ ++ // Quick return if there are no shifts to apply ++ ++ if (np == 0) { return; } ++ ++ // Chase the bulge with the application of each ++ // implicit shift. Each shift is applied to the ++ // whole matrix including each block. ++ ++ cconj = 0; ++ ++ // Loop over the shifts ++ ++ for (jj = 0; jj < np; jj++) ++ { ++ sigmar = shiftr[jj]; ++ sigmai = shifti[jj]; ++ ++ if (cconj) ++ { ++ ++ // Skip flag is on; turn it off and proceed to the next shift. ++ ++ cconj = 0; ++ continue; ++ ++ } else if ((jj < np - 1) && fabsf(sigmai) != 0.0) { ++ ++ // This shift has nonzero imaginary part, so we will apply ++ // together with the next one; turn on the skip flag. ++ ++ cconj = 1; ++ ++ } else if ((jj == np - 1) && (fabsf(sigmai) != 0.0)) { ++ ++ // We have one block left but the shift has nonzero imaginary part. ++ // Don't apply it and reduce the number of shifts by incrementing ++ // kev by one. ++ ++ *kev += 1; ++ continue; ++ } ++ ++ // if sigmai = 0 then ++ // Apply the jj-th shift ... ++ // else ++ // Apply the jj-th and (jj+1)-th together ... ++ // (Note that jj < np at this point in the code) ++ // end ++ // to the current block of H ++ ++ istart = 0; ++ while (istart < kplusp - 1) ++ { ++ for (iend = istart; iend < kplusp - 1; iend++) ++ { ++ tst1 = fabsf(h[iend + (iend * ldh)]) + fabsf(h[iend + 1 + (iend + 1) * ldh]); ++ if (tst1 == 0.0) ++ { ++ tmp_int = kplusp - jj; ++ tst1 = slanhs_("1", &tmp_int, h, &ldh, workl); ++ } ++ if (fabsf(h[iend+1 + (iend * ldh)]) <= fmaxf(smlnum, ulp * tst1)) ++ { ++ break; ++ } ++ } ++ if (istart == iend) ++ { ++ istart += 1; ++ continue; ++ } else if ((istart + 1 == iend) && fabsf(sigmai) > 0.0) { ++ istart += 2; ++ continue; ++ } else { ++ h[iend+1 + (iend * ldh)] = 0.0; ++ } ++ ++ // We have a block [istart, iend] inclusive. ++ h11 = h[istart + istart * ldh]; ++ h21 = h[istart + 1 + istart * ldh]; ++ ++ if (fabsf(sigmai) == 0.0) ++ { ++ ++ f = h11 - sigmar; ++ g = h21; ++ for (i = istart; i < iend; i++) ++ { ++ slartgp_(&f, &g, &c, &s, &r); ++ if (i > istart) ++ { ++ h[i + (i - 1) * ldh] = r; ++ h[i + 1 + (i - 1) * ldh] = 0.0; ++ } ++ tmp_int = kplusp - i; ++ srot_(&tmp_int, &h[i + ldh*i], &ldh, &h[i + 1 + ldh*i], &ldh, &c, &s); ++ tmp_int = (i+2 > iend ? iend : i + 2) + 1; ++ srot_(&tmp_int, &h[ldh*i], &int1, &h[ldh*(i+1)], &int1, &c, &s); ++ tmp_int = (i+jj+2 > kplusp ? kplusp : i + jj + 2); ++ srot_(&tmp_int, &q[ldq*i], &int1, &q[ldq*(i+1)], &int1, &c, &s); ++ ++ if (i < iend - 1) ++ { ++ f = h[i+1 + i * ldh]; ++ g = h[i+2 + i * ldh]; ++ } ++ } ++ } else { ++ ++ h12 = h[istart + ldh*(istart + 1)]; ++ h22 = h[istart + 1 + ldh*(istart + 1)]; ++ h32 = h[istart + 2 + ldh*(istart + 1)]; ++ ++ s = 2.0*sigmar; ++ t = hypotf(sigmar, sigmai); ++ u[0] = (h11*(h11 - s) + t*t) / h21 + h12; ++ u[1] = h11 + h22 - s; ++ u[2] = h32; ++ ++ for (i = istart; i < iend; i++) ++ { ++ nr = iend - i + 1; ++ nr = (nr > 3? 3 : nr); ++ slarfg_(&nr, &u[0], &u[1], &int1, &tau); ++ if (i > istart) ++ { ++ h[i + (i - 1) * ldh] = u[0]; ++ h[i + 1 + (i - 1) * ldh] = 0.0; ++ if (i < iend - 1) { h[i + 2 + (i - 1) * ldh] = 0.0; } ++ } ++ u[0] = 1.0; ++ ++ tmp_int = kplusp - i; ++ slarf_("L", &nr, &tmp_int, u, &int1, &tau, &h[i + ldh*i], &ldh, workl); ++ ir = (i + 3 > iend ? iend : i + 3) + 1; ++ slarf_("R", &ir, &nr, u, &int1, &tau, &h[ldh*i], &ldh, workl); ++ slarf_("R", &kplusp, &nr, u, &int1, &tau, &q[ldq*i], &ldq, workl); ++ if (i < iend - 1) ++ { ++ u[0] = h[i+1 + i * ldh]; ++ u[1] = h[i+2 + i * ldh]; ++ if (i < iend-2) { u[2] = h[i+3 + i * ldh]; } ++ } ++ } ++ } ++ istart = iend + 1; ++ } ++ } ++ // Perform a similarity transformation that makes ++ // sure that H will have non negative sub diagonals ++ ++ for (j = 0; j < *kev; j++) ++ { ++ if (h[j+1 + ldh*j] < 0.0) ++ { ++ tmp_int = kplusp - j; ++ sscal_(&tmp_int, &dblm1, &h[j+1 + ldh*j], &ldh); ++ tmp_int = (j+3 > kplusp ? kplusp : j+3); ++ sscal_(&tmp_int, &dblm1, &h[ldh*(j+1)], &int1); ++ tmp_int = (j+np+2 > kplusp ? kplusp : j+np+2); ++ sscal_(&tmp_int, &dblm1, &q[ldq*(j+1)], &int1); ++ } ++ } ++ // 120 ++ ++ for (i = 0; i < *kev; i++) ++ { ++ ++ // Final check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine dlahqr ++ ++ tst1 = fabsf(h[i + ldh*i]) + fabsf(h[i+1 + ldh*(i+1)]); ++ if (tst1 == 0.0) ++ { ++ tst1 = slanhs_("1", kev, h, &ldh, workl); ++ } ++ if (h[i+1 + ldh*i] <= fmaxf(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = 0.0; ++ } ++ } ++ // 130 ++ ++ // Compute the (kev+1)-st column of (V*Q) and ++ // temporarily store the result in WORKD(N+1:2*N). ++ // This is needed in the residual update since we ++ // cannot GUARANTEE that the corresponding entry ++ // of H would be zero as in exact arithmetic. ++ ++ if (h[*kev + ldh*(*kev-1)] > 0.0) ++ { ++ sgemv_("N", &n, &kplusp, &dbl1, v, &ldv, &q[(*kev)*ldq], &int1, &dbl0, &workd[n], &int1); ++ } ++ ++ // Compute column 1 to kev of (V*Q) in backward order ++ // taking advantage of the upper Hessenberg structure of Q. ++ ++ for (i = 0; i < *kev; i++) ++ { ++ tmp_int = kplusp - i; ++ sgemv_("N", &n, &tmp_int, &dbl1, v, &ldv, &q[(*kev-i-1)*ldq], &int1, &dbl0, workd, &int1); ++ scopy_(&n, workd, &int1, &v[(kplusp-i-1)*ldv], &int1); ++ } ++ ++ // Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). ++ ++ for (i = 0; i < *kev; i++) ++ { ++ scopy_(&n, &v[(kplusp-*kev+i)*ldv], &int1, &v[i*ldv], &int1); ++ } ++ ++ // Copy the (kev+1)-st column of (V*Q) in the appropriate place ++ ++ if (h[*kev + ldh*(*kev-1)] > 0.0){ ++ scopy_(&n, &workd[n], &int1, &v[ldv*(*kev)], &int1); ++ } ++ ++ // Update the residual vector: ++ // r <- sigmak*r + betak*v(:,kev+1) ++ // where ++ // sigmak = (e_{kplusp}'*Q)*e_{kev} ++ // betak = e_{kev+1}'*H*e_{kev} ++ ++ sscal_(&n, &q[kplusp-1 + ldq*(*kev-1)], resid, &int1); ++ ++ if (h[*kev + ldh*(*kev-1)] > 0.0) ++ { ++ saxpy_(&n, &h[*kev + ldh*(*kev-1)], &v[ldv*(*kev)], &int1, resid, &int1); ++ } ++ ++ return; ++ ++} ++ ++ ++void ++sngets(struct ARPACK_arnoldi_update_vars_s *V, int* kev, int* np, ++ float* ritzr, float* ritzi, float* bounds) ++{ ++ ++ // LM, SM, LR, SR, LI, SI case. ++ // Sort the eigenvalues of H into the desired order ++ // and apply the resulting order to BOUNDS. ++ // The eigenvalues are sorted so that the wanted part ++ // are always in the last KEV locations. ++ // We first do a pre-processing sort in order to keep ++ // complex conjugate pairs together ++ ++ switch (V->which) ++ { ++ case which_LM: ++ ssortc(which_LR, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_SM: ++ ssortc(which_SR, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_LR: ++ ssortc(which_LM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_SR: ++ ssortc(which_SM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_LI: ++ ssortc(which_LM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ case which_SI: ++ ssortc(which_SM, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ default: ++ ssortc(which_LR, 1, *kev + *np, ritzr, ritzi, bounds); ++ break; ++ } ++ ssortc(V->which, 1, *kev + *np, ritzr, ritzi, bounds); ++ ++ // Increase KEV by one if the ( ritzr(np),ritzi(np) ) ++ // = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero ++ // Accordingly decrease NP by one. In other words keep ++ // complex conjugate pairs together. ++ ++ if ((ritzr[*np] - ritzr[*np-1] == 0.0) && (ritzi[*np] + ritzi[*np-1] == 0.0)) ++ { ++ *np -= 1; ++ *kev += 1; ++ } ++ ++ if (V->shift == 1) ++ { ++ ++ // Sort the unwanted Ritz values used as shifts so that ++ // the ones with largest Ritz estimates are first ++ // This will tend to minimize the effects of the ++ // forward instability of the iteration when they shifts ++ // are applied in subroutine dnapps. ++ // Be careful and use 'SR' since we want to sort BOUNDS! ++ ++ ssortc(which_SR, 1, *np, bounds, ritzr, ritzi); ++ } ++ ++ return; ++} ++ ++void ++sgetv0(struct ARPACK_arnoldi_update_vars_s *V, int initv, int n, int j, ++ float* v, int ldv, float* resid, float* rnorm, int* ipntr, float* workd) ++{ ++ int jj, int1 = 1; ++ const float sq2o2 = sqrtf(2.0) / 2.0; ++ float dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0;; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->info = 0; ++ V->getv0_iter = 0; ++ V->getv0_first = 0; ++ V->getv0_orth = 0; ++ ++ // Possibly generate a random starting vector in RESID ++ // Skip if this the return of ido_RANDOM. ++ ++ if (!(initv)) ++ { ++ // Request a random vector from the user into resid ++ V->ido = ido_RANDOM; ++ return; ++ } else { ++ V->ido = ido_RANDOM; ++ } ++ } ++ ++ // Back from random vector generation ++ if (V->ido == ido_RANDOM) ++ { ++ // Force the starting vector into the range of OP to handle ++ // the generalized problem when B is possibly (singular). ++ ++ if (V->getv0_itry == 1) ++ { ++ ipntr[0] = 0; ++ ipntr[1] = n; ++ scopy_(&n, resid, &int1, workd, &int1); ++ V->ido = ido_RANDOM_OPX; ++ return; ++ } else if ((V->getv0_itry > 1) && (V->bmat == 1)) ++ { ++ scopy_(&n, resid, &int1, &workd[n], &int1); ++ } ++ } ++ ++ // Back from computing OP*(initial-vector) ++ ++ if (V->getv0_first) { goto LINE20; } ++ ++ // Back from computing OP*(orthogonalized-vector) ++ ++ if (V->getv0_orth) { goto LINE40; } ++ ++ // Starting vector is now in the range of OP; r = OP*r; ++ // Compute B-norm of starting vector. ++ ++ V->getv0_first = 1; ++ if (V->getv0_itry == 1) ++ { ++ scopy_(&n, &workd[n], &int1, resid, &int1); ++ } ++ if (V->bmat) ++ { ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ scopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE20: ++ ++ V->getv0_first = 0; ++ if (V->bmat) ++ { ++ V->getv0_rnorm0 = sdot_(&n, resid, &int1, workd, &int1); ++ V->getv0_rnorm0 = sqrtf(fabsf(V->getv0_rnorm0)); ++ } else { ++ V->getv0_rnorm0 = snrm2_(&n, resid, &int1); ++ } ++ *rnorm = V->getv0_rnorm0; ++ ++ // Exit if this is the very first Arnoldi step ++ ++ if (j == 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Otherwise need to B-orthogonalize the starting vector against ++ // the current Arnoldi basis using Gram-Schmidt with iter. ref. ++ // This is the case where an invariant subspace is encountered ++ // in the middle of the Arnoldi factorization. ++ // ++ // s = V^{T}*B*r; r = r - V*s; ++ // ++ // Stopping criteria used for iter. ref. is discussed in ++ // Parlett's book, page 107 and in Gragg & Reichel TOMS paper. ++ ++ V->getv0_orth = 1; ++ ++LINE30: ++ ++ sgemv_("T", &n, &j, &dbl1, v, &ldv, workd, &int1, &dbl0, &workd[n], &int1); ++ sgemv_("N", &n, &j, &dblm1, v, &ldv, &workd[n], &int1, &dbl1, resid, &int1); ++ ++ // Compute the B-norm of the orthogonalized starting vector ++ ++ if (V->bmat) ++ { ++ scopy_(&n, resid, &int1, &workd[n], &int1); ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ scopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE40: ++ if (V->bmat) ++ { ++ *rnorm = sdot_(&n, resid, &int1, workd, &int1); ++ *rnorm = sqrtf(fabsf(*rnorm)); ++ } else { ++ *rnorm = snrm2_(&n, resid, &int1); ++ } ++ ++ // Check for further orthogonalization. ++ ++ if (*rnorm > sq2o2*V->getv0_rnorm0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->getv0_iter += 1; ++ if (V->getv0_iter < 5) ++ { ++ ++ // Perform iterative refinement step ++ ++ V->getv0_rnorm0 = *rnorm; ++ goto LINE30; ++ } else { ++ ++ // Iterative refinement step "failed" ++ ++ for (jj = 0; jj < n; jj++) { resid[jj] = 0.0; } ++ *rnorm = 0.0; ++ V->info = -1; ++ } ++ ++ V->ido = ido_DONE; ++ ++ return; ++} ++ ++void ++ssortc(const enum ARPACK_which w, const int apply, const int n, float* xreal, float* ximag, float* y) ++{ ++ int i, igap, j; ++ float temp; ++ ARPACK_compare_cfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortc_LM; ++ break; ++ case which_SM: ++ f = sortc_SM; ++ break; ++ case which_LR: ++ f = sortc_LR; ++ break; ++ case which_LI: ++ f = sortc_LI; ++ break; ++ case which_SR: ++ f = sortc_SR; ++ break; ++ case which_SI: ++ f = sortc_SI; ++ break; ++ default: ++ f = sortc_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(xreal[j], ximag[j], xreal[j+igap], ximag[j+igap])) ++ { ++ if (j < 0) { break; } ++ temp = xreal[j]; ++ xreal[j] = xreal[j+igap]; ++ xreal[j+igap] = temp; ++ temp = ximag[j]; ++ ximag[j] = ximag[j+igap]; ++ ximag[j+igap] = temp; ++ ++ if (apply) ++ { ++ temp = y[j]; ++ y[j] = y[j+igap]; ++ y[j+igap] = temp; ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++} ++ ++// The void casts are to avoid compiler warnings for unused parameters ++int ++sortc_LM(const float xre, const float xim, const float xreigap, const float ximigap) ++{ ++ return (hypotf(xre, xim) > hypotf(xreigap, ximigap)); ++} ++ ++int ++sortc_SM(const float xre, const float xim, const float xreigap, const float ximigap) ++{ ++ return (hypotf(xre, xim) < hypotf(xreigap, ximigap)); ++} ++ ++int ++sortc_LR(const float xre, const float xim, const float xreigap, const float ximigap) ++{ ++ (void)xim; (void)ximigap; ++ return (xre > xreigap); ++} ++ ++int ++sortc_SR(const float xre, const float xim, const float xreigap, const float ximigap) ++{ ++ (void)xim; (void)ximigap; ++ return (xre < xreigap); ++} ++ ++int ++sortc_LI(const float xre, const float xim, const float xreigap, const float ximigap) ++{ ++ (void)xre; (void)xreigap; ++ return (fabsf(xim) > fabsf(ximigap)); ++} ++ ++int ++sortc_SI(const float xre, const float xim, const float xreigap, const float ximigap) ++{ ++ (void)xre; (void)xreigap; ++ return (fabsf(xim) < fabsf(ximigap)); ++} +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.h +new file mode 100644 +index 0000000000..f869f6bd5a +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single.h +@@ -0,0 +1,32 @@ ++#ifndef _ARPACK_N_SINGLE_H ++#define _ARPACK_N_SINGLE_H ++ ++#include "_arpack.h" ++ ++// BLAS Routines used ++void saxpy_(int* n, float* alpha, float* x, int* incx, float* y, int* incy); ++void scopy_(int* n, float* x, int* incx, float* y, int* incy); ++float sdot_(int* n, float* x, int* incx, float* y, int* incy); ++void sger_(int* m, int* n, float* alpha, float* x, int* incx, float* y, int* incy, float* a, int* lda); ++float snrm2_(int* n, float* x, int* incx); ++void sscal_(int* n, float* alpha, float* x, int* incx); ++void sgemv_(char* trans, int* m, int* n, float* alpha, float* a, int* lda, float* x, int* incx, float* beta, float* y, int* incy); ++void srot_(int* n, float* x, int* incx, float* y, int* incy, float* c, float* s); ++void strmm_(char* side, char* uplo, char* transa, char* diag, int* m, int* n, float* alpha, float* a, int* lda, float* b, int* ldb); ++ ++// LAPACK Routines used ++void sgeqr2_(int* m, int* n, float* a, int* lda, float* tau, float* work, int* info); ++void slacpy_(char* uplo, int* m, int* n, float* a, int* lda, float* b, int* ldb); ++void slahqr_(int* wantt, int* wantz, int* n, int* ilo, int* ihi, float* h, int* ldh, float* wr, float* wi, int* iloz, int* ihiz, float* z, int* ldz, int* info ); ++float slanhs_(char* norm, int* n, float* a, int* lda, float* work); ++void slaset_(char* uplo, int* m, int* n, float* alpha, float* beta, float* a, int* lda); ++void slarf_(char* side, int* m, int* n, float* v, int* incv, float* tau, float* c, int* ldc, float* work); ++void slarfg_(int* n, float* alpha, float* x, int* incx, float* tau); ++void slartg_(float* f, float* g, float* c, float* s, float* r); ++void slartgp_(float* f, float* g, float* c, float* s, float* r); ++void slascl_(char* mtype, int* kl, int* ku, float* cfrom, float* cto, int* m, int* n, float* a, int* lda, int* info); ++void sorm2r_(char* side, char* trans, int* m, int* n, int* k, float* a, int* lda, float* tau, float* c, int* ldc, float* work, int* info); ++void strevc_(char* side, char* howmny, int* select, int* n, float* t, int* ldt, float* vl, int* ldvl, float* vr, int* ldvr, int* mm, int* m, float* work, int* info); ++void strsen_(char* job, char* compq, int* select, int* n, float* t, int* ldt, float* q, int* ldq, float* wr, float* wi, int* m, float* s, float* sep, float* work, int* lwork, int* iwork, int* liwork, int* info); ++ ++#endif +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.c b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.c +new file mode 100644 +index 0000000000..d9e2037a86 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.c +@@ -0,0 +1,1861 @@ ++#include "_arpack_n_single_complex.h" ++ ++typedef int ARPACK_compare_cfunc(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++typedef int ARPACK_compare_rfunc(const float, const float); ++ ++static const float unfl = 1.1754943508222875e-38; ++// static const float ovfl = 1.0 / 1.1754943508222875e-38; ++static const float ulp = 1.1920928955078125e-07; ++ ++static ARPACK_CPLXF_TYPE cdotc_(const int* n, const ARPACK_CPLXF_TYPE* restrict x, const int* incx, const ARPACK_CPLXF_TYPE* restrict y, const int* incy); ++static void cgetv0(struct ARPACK_arnoldi_update_vars_s*, int, int, int, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, float*, int*, ARPACK_CPLXF_TYPE*); ++static void cnaup2(struct ARPACK_arnoldi_update_vars_s*, ARPACK_CPLXF_TYPE* , ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, int*, ARPACK_CPLXF_TYPE*, float*); ++static void cnaitr(struct ARPACK_arnoldi_update_vars_s*, int, int, ARPACK_CPLXF_TYPE*,float*, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, int, int*, ARPACK_CPLXF_TYPE*); ++static void cnapps(int, int*, int, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*); ++static void cneigh(float*, int, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*, int, ARPACK_CPLXF_TYPE*, float*, int*); ++static void cngets(struct ARPACK_arnoldi_update_vars_s*, int*, int*, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*); ++static void csortc(const enum ARPACK_which w, const int, const int, ARPACK_CPLXF_TYPE*, ARPACK_CPLXF_TYPE*); ++static int sortc_LM(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++static int sortc_SM(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++static int sortc_LR(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++static int sortc_SR(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++static int sortc_LI(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++static int sortc_SI(const ARPACK_CPLXF_TYPE, const ARPACK_CPLXF_TYPE); ++ ++enum ARPACK_neupd_type { ++ REGULAR, ++ SHIFTI, ++ REALPART, ++ IMAGPART ++}; ++ ++ ++void ++ARPACK_cneupd(struct ARPACK_arnoldi_update_vars_s *V, int rvec, int howmny, int* select, ++ ARPACK_CPLXF_TYPE* d, ARPACK_CPLXF_TYPE* z, int ldz, ARPACK_CPLXF_TYPE sigma, ++ ARPACK_CPLXF_TYPE* workev, ARPACK_CPLXF_TYPE* resid, ARPACK_CPLXF_TYPE* v, int ldv, ++ int* ipntr, ARPACK_CPLXF_TYPE* workd, ARPACK_CPLXF_TYPE* workl, float* rwork) ++{ ++ const float eps23 = pow(ulp, 2.0 / 3.0); ++ int ibd, ih, iheig, ihbds, iuptri, invsub, irz, iwev, j, jj; ++ int bounds, k, ldh, ldq, np, numcnv, outncv, reord, ritz, wr; ++ int ierr = 0, int1 = 1, tmp_int = 0, nconv2 = 0; ++ float conds, sep, temp1, rtemp; ++ ARPACK_CPLXF_TYPE rnorm, temp; ++ ARPACK_CPLXF_TYPE cdbl0 = ARPACK_cplxf(0.0, 0.0); ++ ARPACK_CPLXF_TYPE cdbl1 = ARPACK_cplxf(1.0, 0.0); ++ ARPACK_CPLXF_TYPE cdblm1 = ARPACK_cplxf(-1.0, 0.0); ++ ARPACK_CPLXF_TYPE vl[1] = { cdbl0 }; ++ enum ARPACK_neupd_type TYP; ++ ++ if (V->nconv <= 0) { ++ ierr = -14; ++ } else if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv <= V->nev + 1) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if ((V->which > 5) || (V->which < 0)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((rvec) && ((howmny < 0) || (howmny > 2))) { ++ ierr = -13; ++ } else if (howmny == 2) { ++ ierr = -12; // NotImplementedError ++ } ++ ++ if ((V->mode == 1) || (V->mode == 2)) { ++ TYP = REGULAR; ++ } else if (V->mode == 3) { ++ TYP = SHIFTI; ++ } else { ++ ierr = -10; ++ } ++ ++ if ((V->mode == 1) && (V->bmat)) { ierr = -11; } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ return; ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, WORKEV, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:ncv*ncv) := generated Hessenberg matrix ++ // workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values ++ // workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds ++ ++ // The following is used and set by ZNEUPD. ++ // workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed ++ // Ritz values. ++ // workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed ++ // error bounds of ++ // the Ritz values ++ // workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper ++ // triangular matrix ++ // for H. ++ // workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the ++ // associated matrix ++ // representation of ++ // the invariant ++ // subspace for H. ++ // GRAND total of NCV * ( 3 * NCV + 4 ) locations. ++ ++ ih = ipntr[4]; ++ ritz = ipntr[5]; ++ bounds = ipntr[7]; ++ ldh = V->ncv; ++ ldq = V->ncv; ++ iheig = bounds + ldh; ++ ihbds = iheig + ldh; ++ iuptri = ihbds + ldh; ++ invsub = iuptri + ldh*V->ncv; ++ ipntr[8] = iheig; ++ ipntr[10] = ihbds; ++ ipntr[11] = iuptri; ++ ipntr[12] = invsub; ++ wr = 0; ++ iwev = wr + V->ncv; ++ ++ // irz points to the Ritz values computed ++ // by _neigh before exiting _naup2. ++ // ibd points to the Ritz estimates ++ // computed by _neigh before exiting ++ // _naup2. ++ ++ irz = ipntr[13] + (V->ncv)*(V->ncv); ++ ibd = irz + V->ncv; ++ ++ // RNORM is B-norm of the RESID(1:N). ++ ++ rnorm = workl[ih+2]; ++ workl[ih+2] = ARPACK_cplxf(0.0, 0.0); ++ ++ if (rvec) { ++ reord = 0; ++ ++ // Use the temporary bounds array to store indices ++ // These will be used to mark the select array later ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[bounds + j] = ARPACK_cplxf(j, 0.0); ++ select[j] = 0; ++ } ++ // 10 ++ ++ // Select the wanted Ritz values. ++ // Sort the Ritz values so that the ++ // wanted ones appear at the tailing ++ // NEV positions of workl(irr) and ++ // workl(iri). Move the corresponding ++ // error estimates in workl(ibd) ++ // accordingly. ++ ++ np = V->ncv - V->nev; ++ cngets(V, &V->nev, &np, &workl[irz], &workl[bounds]); ++ ++ // Record indices of the converged wanted Ritz values ++ // Mark the select array for possible reordering ++ ++ numcnv = 0; ++ for (j = 1; j <= V->ncv; j++) ++ { ++ temp1 = fmax(eps23, cabsf(workl[irz + V->ncv - j])); ++ jj = (int)crealf(workl[bounds + V->ncv - j]); ++ ++ if ((numcnv < V->nconv) && (cabsf(workl[ibd + jj]) <= V->tol*temp1)) ++ { ++ select[jj] = 1; ++ numcnv += 1; ++ if (jj > V->nconv - 1) { reord = 1; } ++ } ++ } ++ // 11 ++ ++ // Check the count (numcnv) of converged Ritz values with ++ // the number (nconv) reported by znaupd. If these two ++ // are different then there has probably been an error ++ // caused by incorrect passing of the znaupd data. ++ ++ if (numcnv != V->nconv) ++ { ++ V->info = -15; ++ return; ++ } ++ ++ // Call LAPACK routine zlahqr to compute the Schur form ++ // of the upper Hessenberg matrix returned by ZNAUPD . ++ // Make a copy of the upper Hessenberg matrix. ++ // Initialize the Schur vector matrix Q to the identity. ++ ++ tmp_int = ldh*V->ncv; ++ ccopy_(&tmp_int, &workl[ih], &int1, &workl[iuptri], &int1); ++ claset_("A", &V->ncv, &V->ncv, &cdbl0, &cdbl1, &workl[invsub], &ldq); ++ clahqr_(&int1, &int1, &V->ncv, &int1, &V->ncv, &workl[iuptri], &ldh, ++ &workl[iheig], &int1, &V->ncv, &workl[invsub], &ldq, &ierr); ++ ccopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ if (ierr != 0) ++ { ++ V->info = -8; ++ return; ++ } ++ ++ if (reord) ++ { ++ ++ // Reorder the computed upper triangular matrix. ++ ++ ctrsen_("N", "V", select, &V->ncv, &workl[iuptri], &ldh, &workl[invsub], &ldq, ++ &workl[iheig], &nconv2, &conds, &sep, workev, &V->ncv, &ierr); ++ ++ if (nconv2 < V->nconv) { V->nconv = nconv2; } ++ if (ierr == 1) { ++ V->info = 1; ++ return; ++ } ++ } ++ ++ // Copy the last row of the Schur basis matrix ++ // to workl(ihbds). This vector will be used ++ // to compute the Ritz estimates of converged ++ // Ritz values. ++ ++ ccopy_(&V->ncv, &workl[invsub + V->ncv - 1], &ldq, &workl[ihbds], &int1); ++ ++ // Place the computed eigenvalues of H into D ++ // if a spectral transformation was not used. ++ ++ if (TYP == REGULAR) ++ { ++ ccopy_(&V->nconv, &workl[iheig], &int1, d, &int1); ++ } ++ ++ // Compute the QR factorization of the matrix representing ++ // the wanted invariant subspace located in the first NCONV ++ // columns of workl(invsub,ldq). ++ ++ cgeqr2_(&V->ncv, &V->nconv, &workl[invsub], &ldq, workev, &workev[V->ncv], &ierr); ++ ++ // * Postmultiply V by Q using zunm2r. ++ // * Copy the first NCONV columns of VQ into Z. ++ // * Postmultiply Z by R. ++ // The N by NCONV matrix Z is now a matrix representation ++ // of the approximate invariant subspace associated with ++ // the Ritz values in workl(iheig). The first NCONV ++ // columns of V are now approximate Schur vectors ++ // associated with the upper triangular matrix of order ++ // NCONV in workl(iuptri). ++ ++ cunm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[invsub], &ldq, workev, v, &ldv, &workd[V->n], &ierr); ++ clacpy_("A", &V->n, &V->nconv, v, &ldv, z, &ldz); ++ ++ for (int j = 0; j < V->nconv; j++) ++ { ++ ++ // Perform both a column and row scaling if the ++ // diagonal element of workl(invsub,ldq) is negative ++ // I'm lazy and don't take advantage of the upper ++ // triangular form of workl(iuptri,ldq). ++ // Note that since Q is orthogonal, R is a diagonal ++ // matrix consisting of plus or minus ones. ++ ++ if (crealf(workl[invsub + j*ldq + j]) < 0.0) ++ { ++ cscal_(&V->nconv, &cdblm1, &workl[iuptri + j], &ldq); ++ cscal_(&V->nconv, &cdblm1, &workl[iuptri + j*ldq], &int1); ++ } ++ } ++ // 20 ++ ++ if (howmny == 0) ++ { ++ ++ // Compute the NCONV wanted eigenvectors of T ++ // located in workl(iuptri,ldq). ++ ++ for (int j = 0; j < V->ncv; j++) ++ { ++ if (j < V->nconv) ++ { ++ select[j] = 1; ++ } else { ++ select[j] = 0; ++ } ++ } ++ // 30 ++ ++ ctrevc_("R", "S", select, &V->ncv, &workl[iuptri], &ldq, vl, &int1, ++ &workl[invsub], &ldq, &V->ncv, &outncv, workev, rwork, &ierr); ++ if (ierr != 0) ++ { ++ V->info = -9; ++ return; ++ } ++ ++ // Scale the returning eigenvectors so that their ++ // Euclidean norms are all one. LAPACK subroutine ++ // ztrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1. ++ ++ for (j = 0; j < V->nconv; j++) ++ { ++ rtemp = 1.0 / scnrm2_(&V->ncv, &workl[invsub + j*ldq], &int1); ++ csscal_(&V->ncv, &rtemp, &workl[invsub + j*ldq], &int1); ++ ++ // Ritz estimates can be obtained by taking ++ // the inner product of the last row of the ++ // Schur basis of H with eigenvectors of T. ++ // Note that the eigenvector matrix of T is ++ // upper triangular, thus the length of the ++ // inner product can be set to j. ++ tmp_int = j + 1; ++ workev[j] = cdotc_(&tmp_int, &workl[ihbds], &int1, &workl[invsub + j*ldq], &int1); ++ } ++ // 40 ++ ++ // Copy Ritz estimates into workl(ihbds) ++ ++ ccopy_(&V->nconv, workev, &int1, &workl[ihbds], &int1); ++ ++ // The eigenvector mactirx Q of T is triangular. Form Z*Q ++ ++ ctrmm_("R", "U", "N", "N", &V->n, &V->nconv, &cdbl1, &workl[invsub], &ldq, z, &ldz); ++ ++ } ++ ++ } else { ++ ++ // An approximate invariant subspace is not needed. ++ // Place the Ritz values computed ZNAUPD into D. ++ ++ ccopy_(&V->nconv, &workl[ritz], &int1, d, &int1); ++ ccopy_(&V->nconv, &workl[ritz], &int1, &workl[iheig], &int1); ++ ccopy_(&V->nconv, &workl[bounds], &int1, &workl[ihbds], &int1); ++ ++ } ++ ++ // Transform the Ritz values and possibly vectors ++ // and corresponding error bounds of OP to those ++ // of A*x = lambda*B*x. ++ ++ if (TYP == REGULAR) ++ { ++ if (rvec) ++ { ++ cscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ } else { ++ ++ // A spectral transformation was used. ++ // * Determine the Ritz estimates of the ++ // Ritz values in the original system. ++ ++ if (rvec) ++ { ++ cscal_(&V->ncv, &rnorm, &workl[ihbds], &int1); ++ } ++ for (k = 0; k < V->ncv; k++) ++ { ++#if defined(_MSC_VER) ++ // Complex division is not supported in MSVC, multiply with reciprocal ++ temp = _FCmulcr(conjf(workl[iheig + k]), 1.0 / cabsf(workl[iheig + k])); ++ workl[ihbds + k] = _FCmulcc(_FCmulcc(workl[ihbds + k], temp), temp); ++#else ++ temp = workl[iheig + k]; ++ workl[ihbds + k] = workl[ihbds + k] / temp / temp; ++#endif ++ } ++ // 50 ++ } ++ ++ // * Transform the Ritz values back to the original system. ++ // For TYPE = 'SHIFTI' the transformation is ++ // lambda = 1/theta + sigma ++ // NOTES: ++ // *The Ritz vectors are not affected by the transformation. ++ ++ if (TYP == SHIFTI) ++ { ++ for (k = 0; k < V->nconv; k++) ++ { ++#if defined(_MSC_VER) ++ // Complex division is not supported in MSVC ++ temp = _FCmulcr(conjf(workl[iheig + k]), 1.0 / cabsf(workl[iheig + k])); ++ d[k] = ARPACK_cplxf(crealf(temp) + crealf(sigma), cimagf(temp) + cimagf(sigma)); ++#else ++ d[k] = 1.0 / workl[iheig + k] + sigma; ++#endif ++ } ++ // 60 ++ } ++ ++ // Eigenvector Purification step. Formally perform ++ // one of inverse subspace iteration. Only used ++ // for MODE = 3. See reference 3. ++ ++ if ((rvec) && (howmny == 0) && (TYP == SHIFTI)) ++ { ++ ++ // Purify the computed Ritz vectors by adding a ++ // little bit of the residual vector: ++ // T ++ // resid(:)*( e s ) / theta ++ // NCV ++ // where H s = s theta. ++ ++ for (j = 0; j < V->nconv; j++) ++ { ++ if ((crealf(workl[iheig+j]) != 0.0) || (cimagf(workl[iheig+j]) != 0.0)) ++ { ++#if defined(_MSC_VER) ++ // Complex division is not supported in MSVC ++ temp = _FCmulcr(conjf(workl[iheig + j]), 1.0 / cabsf(workl[iheig + j])); ++ workev[j] = _FCmulcc(workl[invsub + j*ldq + V->ncv], temp); ++#else ++ workev[j] = workl[invsub + j*ldq + V->ncv] / workl[iheig+j]; ++#endif ++ } ++ } ++ // 100 ++ ++ // Perform a rank one update to Z and ++ // purify all the Ritz vectors together. ++ ++ cgeru_(&V->n, &V->nconv, &cdbl1, resid, &int1, workev, &int1, z, &ldz); ++ } ++ ++ return; ++} ++ ++ ++void ++ARPACK_cnaupd(struct ARPACK_arnoldi_update_vars_s *V, ARPACK_CPLXF_TYPE* resid, ++ ARPACK_CPLXF_TYPE* v, int ldv, int* ipntr, ARPACK_CPLXF_TYPE* workd, ++ ARPACK_CPLXF_TYPE* workl, float* rwork) ++{ ++ int bounds, ierr = 0, ih, iq, iw, ldh, ldq, next, iritz; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // perform basic checks ++ if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv < V->nev + 1) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if (V->maxiter <= 0) { ++ ierr = -4; ++ } else if ((V->which < 0) || (V->which > 5)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((V->mode < 1) || (V->mode > 3)) { ++ ierr = -10; ++ } else if ((V->mode == 1) && (V->bmat == 1)) { ++ ierr = -11; ++ } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ V->ido = 99; ++ return; ++ } ++ ++ if (V->tol <= 0.0) { ++ V-> tol = ulp; ++ } ++ ++ if ((V->shift != 0) && (V->shift != 1) && (V->shift != 2)) ++ { ++ V->shift = 1; ++ } ++ ++ // NP is the number of additional steps to ++ // extend the length NEV Lanczos factorization. ++ // NEV0 is the local variable designating the ++ // size of the invariant subspace desired. ++ ++ V->np = V->ncv - V->nev; ++ ++ for (int j = 0; j < 3 * (V->ncv*V->ncv) + 6*V->ncv; j++) ++ { ++ workl[j] = ARPACK_cplxf(0.0, 0.0); ++ } ++ } ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:ncv*ncv) := generated Hessenberg matrix ++ // workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values ++ // workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds ++ // workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q ++ // workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace ++ // The final workspace is needed by subroutine zneigh called ++ // by znaup2 . Subroutine zneigh calls LAPACK routines for ++ // calculating eigenvalues and the last row of the eigenvector ++ // matrix. ++ ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ih = 0; ++ iritz = ih + ldh*V->ncv; ++ bounds = iritz + V->ncv; ++ iq = bounds + V->ncv; ++ iw = iq + ldq*V->ncv; ++ next = iw + (V->ncv*V->ncv) + 3*V->ncv; ++ ++ ipntr[3] = next; ++ ipntr[4] = ih; ++ ipntr[5] = iritz; ++ ipntr[6] = iq; ++ ipntr[7] = bounds; ++ ipntr[13] = iw; ++ ++ cnaup2(V, resid, v, ldv, &workl[ih], ldh, &workl[iritz], &workl[bounds], ++ &workl[iq], ldq, &workl[iw], ipntr, workd, rwork); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP or shifts. ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ V->nconv = V->np; ++ ++ if (V->info < 0) { return; } ++ if (V->info == 2) { V->info = 3; } ++ ++ return; ++} ++ ++ ++void ++cnaup2(struct ARPACK_arnoldi_update_vars_s *V, ARPACK_CPLXF_TYPE* resid, ++ ARPACK_CPLXF_TYPE* v, int ldv, ARPACK_CPLXF_TYPE* h, int ldh, ++ ARPACK_CPLXF_TYPE* ritz, ARPACK_CPLXF_TYPE* bounds, ++ ARPACK_CPLXF_TYPE* q, int ldq, ARPACK_CPLXF_TYPE* workl, int* ipntr, ++ ARPACK_CPLXF_TYPE* workd, float* rwork) ++{ ++ enum ARPACK_which temp_which; ++ int i, int1 = 1, j, tmp_int; ++ const float eps23 = pow(ulp, 2.0 / 3.0); ++ float temp = 0.0, rtemp; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->aup2_nev0 = V->nev; ++ V->aup2_np0 = V->np; ++ ++ // kplusp is the bound on the largest ++ // Lanczos factorization built. ++ // nconv is the current number of ++ // "converged" eigenvlues. ++ // iter is the counter on the current ++ // iteration step. ++ ++ V->aup2_kplusp = V->nev + V->np; ++ V->nconv = 0; ++ V->aup2_iter = 0; ++ ++ // Set flags for computing the first NEV ++ // steps of the Arnoldi factorization. ++ ++ V->aup2_getv0 = 1; ++ V->aup2_update = 0; ++ V->aup2_ushift = 0; ++ V->aup2_cnorm = 0; ++ ++ if (V->info != 0) ++ { ++ ++ // User provides the initial residual vector. ++ ++ V->aup2_initv = 1; ++ V->info = 0; ++ } else { ++ V->aup2_initv = 0; ++ } ++ } ++ ++ // Get a possibly random starting vector and ++ // force it into the range of the operator OP. ++ ++ if (V->aup2_getv0) ++ { ++ V->getv0_itry = 1; ++ cgetv0(V, V->aup2_initv, V->n, 0, v, ldv, resid, &V->aup2_rnorm, ipntr, workd); ++ if (V->ido != ido_DONE) { return; } ++ if (V->aup2_rnorm == 0.0) ++ { ++ V->info = -9; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_getv0 = 0; ++ V->ido = ido_FIRST; ++ } ++ ++ // Back from reverse communication : ++ // continue with update step ++ ++ if (V->aup2_update) { goto LINE20; } ++ ++ // Back from computing user specified shifts ++ ++ if (V->aup2_ushift) { goto LINE50; } ++ ++ // Back from computing residual norm ++ // at the end of the current iteration ++ ++ if (V->aup2_cnorm) { goto LINE100; } ++ ++ // Compute the first NEV steps of the Arnoldi factorization ++ ++ cnaitr(V, 0, V->nev, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // ++ // M A I N ARNOLDI I T E R A T I O N L O O P ++ // Each iteration implicitly restarts the Arnoldi ++ // factorization in place. ++ // ++ ++LINE1000: ++ V->aup2_iter += 1; ++ ++ // Compute NP additional steps of the Arnoldi factorization. ++ // Adjust NP since NEV might have been updated by last call ++ // to the shift application routine dnapps . ++ ++ V->np = V->aup2_kplusp - V->nev; ++ V->ido = ido_FIRST; ++ ++LINE20: ++ V->aup2_update = 1; ++ ++ cnaitr(V, V->nev, V->np, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_update = 0; ++ ++ // Compute the eigenvalues and corresponding error bounds ++ // of the current upper Hessenberg matrix. ++ ++ cneigh(&V->aup2_rnorm, V->aup2_kplusp, h, ldh, ritz, bounds, q, ldq, workl, rwork, &V->info); ++ ++ if (V->info != 0) ++ { ++ V->info = -8; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The wanted part of the spectrum and corresponding ++ // error bounds are in the last NEV loc. of RITZ, ++ // and BOUNDS respectively. ++ ++ V->nev = V->aup2_nev0; ++ V->np = V->aup2_np0; ++ ++ // Make a copy of Ritz values and the corresponding ++ // Ritz estimates obtained from zneigh . ++ tmp_int = V->aup2_kplusp * V->aup2_kplusp; ++ ccopy_(&V->aup2_kplusp, ritz, &int1, &workl[tmp_int], &int1); ++ tmp_int += V->aup2_kplusp; ++ ccopy_(&V->aup2_kplusp, bounds, &int1, &workl[tmp_int], &int1); ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The wanted part of the spectrum and corresponding ++ // bounds are in the last NEV loc. of RITZ ++ // BOUNDS respectively. ++ ++ cngets(V, &V->nev, &V->np, ritz, bounds); ++ ++ // Convergence test: currently we use the following criteria. ++ // The relative accuracy of a Ritz value is considered ++ // acceptable if: ++ // ++ // error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). ++ // ++ V->nconv = 0; ++ for (i = 0; i < V->nev; i++) ++ { ++ rtemp = fmax(eps23, cabsf(ritz[V->np + i])); ++ if (cabsf(bounds[V->np + i]) <= V->tol*rtemp) ++ { ++ V->nconv += 1; ++ } ++ } ++ // 25 ++ ++ // Count the number of unwanted Ritz values that have zero ++ // Ritz estimates. If any Ritz estimates are equal to zero ++ // then a leading block of H of order equal to at least ++ // the number of Ritz values with zero Ritz estimates has ++ // split off. None of these Ritz values may be removed by ++ // shifting. Decrease NP the number of shifts to apply. If ++ // no shifts may be applied, then prepare to exit ++ ++ // We are modifying V->np hence the temporary variable. ++ int nptemp = V->np; ++ ++ for (j = 0; j < nptemp; j++) ++ { ++ if ((crealf(bounds[j]) == 0.0) && (cimagf(bounds[j]) == 0.0)) ++ { ++ V->np -= 1; ++ V->nev += 1; ++ } ++ } ++ // 30 ++ ++ if ((V->nconv >= V->aup2_nev0) || (V->aup2_iter > V->maxiter) || (V->np == 0)) ++ { ++ ++ // Prepare to exit. Put the converged Ritz values ++ // and corresponding bounds in RITZ(1:NCONV) and ++ // BOUNDS(1:NCONV) respectively. Then sort. Be ++ // careful when NCONV > NP ++ ++ // Use h( 3,1 ) as storage to communicate ++ // rnorm to _neupd if needed ++ ++ h[2] = ARPACK_cplxf(V->aup2_rnorm, 0.0); ++ ++ // Sort Ritz values so that converged Ritz ++ // values appear within the first NEV locations ++ // of ritz and bounds, and the most desired one ++ // appears at the front. ++ ++ // Translation note: Is this all because ARPACK did not have complex sort? ++ ++ if (V->which == which_LM) { temp_which = which_SM; } ++ if (V->which == which_SM) { temp_which = which_LM; } ++ if (V->which == which_LR) { temp_which = which_SR; } ++ if (V->which == which_SR) { temp_which = which_LR; } ++ if (V->which == which_LI) { temp_which = which_SI; } ++ if (V->which == which_SI) { temp_which = which_LI; } ++ ++ csortc(temp_which, 1, V->aup2_kplusp, ritz, bounds); ++ ++ // Scale the Ritz estimate of each Ritz value ++ // by 1 / max(eps23,magnitude of the Ritz value). ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmax(eps23, cabsf(ritz[j])); ++ bounds[j] = ARPACK_cplxf(crealf(bounds[j]) / temp, cimagf(bounds[j]) / temp); ++ } ++ // 35 ++ ++ // Sort the Ritz values according to the scaled Ritz ++ // estimates. This will push all the converged ones ++ // towards the front of ritzr, ritzi, bounds ++ // (in the case when NCONV < NEV.) ++ ++ temp_which = which_LM; ++ csortc(temp_which, 1, V->aup2_nev0, bounds, ritz); ++ ++ // Scale the Ritz estimate back to its original ++ // value. ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmax(eps23, cabsf(ritz[j])); ++ bounds[j] = ARPACK_cplxf(crealf(bounds[j]) * temp, cimagf(bounds[j]) * temp); ++ } ++ // 40 ++ ++ // Sort the converged Ritz values again so that ++ // the "threshold" value appears at the front of ++ // ritzr, ritzi and bound. ++ ++ csortc(V->which, 1, V->nconv, ritz, bounds); ++ ++ if ((V->aup2_iter > V->maxiter) && (V->nconv < V->aup2_nev0)) ++ { ++ ++ // Max iterations have been exceeded. ++ ++ V->info = 1; ++ } ++ ++ if ((V->np == 0) && (V->nconv < V->aup2_nev0)) ++ { ++ ++ // No shifts to apply. ++ ++ V->info = 2; ++ } ++ ++ V->np = V->nconv; ++ V->iter = V->aup2_iter; ++ V->nev = V->nconv; ++ V->ido = ido_DONE; ++ return; ++ ++ } else if ((V->nconv < V->aup2_nev0) && (V->shift)) { ++ ++ // Do not have all the requested eigenvalues yet. ++ // To prevent possible stagnation, adjust the size ++ // of NEV. ++ ++ int nevbef = V->nev; ++ V->nev += (V->nconv > (V->np / 2) ? (V->np / 2) : V->nconv); ++ if ((V->nev == 1) && (V->aup2_kplusp >= 6)) { ++ V->nev = V->aup2_kplusp / 2; ++ } else if ((V->nev == 1) && (V->aup2_kplusp > 3)) { ++ V->nev = 2; ++ } ++ ++ V->np = V->aup2_kplusp - V->nev; ++ ++ // If the size of NEV was just increased ++ // resort the eigenvalues. ++ ++ if (nevbef < V->nev) { ++ cngets(V, &V->nev, &V->np, ritz, bounds); ++ } ++ } ++ ++ if (V->shift == 0) ++ { ++ ++ // User specified shifts: pop back out to get the shifts ++ // and return them in the first 2*NP locations of WORKL. ++ ++ V->aup2_ushift = 1; ++ V->ido = ido_USER_SHIFT; ++ return; ++ } ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // User specified shifts are returned ++ // in WORKL(1:2*NP) ++ ++ V->aup2_ushift = 0; ++ ++ if (V->shift != 1) ++ { ++ ++ // Move the NP shifts from WORKL to ++ // RITZR, RITZI to free up WORKL ++ // for non-exact shift case. ++ ++ ccopy_(&V->np, workl, &int1, ritz, &int1); ++ } ++ ++ // Apply the NP implicit shifts by QR bulge chasing. ++ // Each shift is applied to the whole upper Hessenberg ++ // matrix H. ++ // The first 2*N locations of WORKD are used as workspace. ++ ++ cnapps(V->n, &V->nev, V->np, ritz, v, ldv, h, ldh, resid, q, ldq, workl, workd); ++ ++ // Compute the B-norm of the updated residual. ++ // Keep B*RESID in WORKD(1:N) to be used in ++ // the first step of the next call to dnaitr . ++ ++ V->aup2_cnorm = 1; ++ if (V->bmat) ++ { ++ ccopy_(&V->n, resid, &int1, &workd[V->n], &int1); ++ ipntr[0] = V->n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*RESID ++ ++ return; ++ } else { ++ ccopy_(&V->n, resid, &int1, workd, &int1); ++ } ++ ++LINE100: ++ ++ // Back from reverse communication; ++ // WORKD(1:N) := B*RESID ++ ++ if (V->bmat) ++ { ++ V->aup2_rnorm = sqrt(cabsf(cdotc_(&V->n, resid, &int1, workd, &int1))); ++ } else { ++ V->aup2_rnorm = scnrm2_(&V->n, resid, &int1); ++ } ++ V->aup2_cnorm = 0; ++ ++ goto LINE1000; ++ ++ // ++ // E N D O F M A I N I T E R A T I O N L O O P ++ // ++ ++} ++ ++ ++static void ++cnaitr(struct ARPACK_arnoldi_update_vars_s *V, int k, int np, ARPACK_CPLXF_TYPE* resid, ++ float* rnorm, ARPACK_CPLXF_TYPE* v, int ldv, ARPACK_CPLXF_TYPE* h, int ldh, ++ int* ipntr, ARPACK_CPLXF_TYPE* workd) ++{ ++ int i, infol, ipj, irj, ivj, jj, n, tmp_int; ++ float smlnum = unfl * ( V->n / ulp); ++ const float sq2o2 = sqrt(2.0) / 2.0; ++ ++ int int1 = 1; ++ float dbl1 = 1.0, temp1, tst1; ++ ARPACK_CPLXF_TYPE cdbl1 = ARPACK_cplxf(1.0, 0.0); ++ ARPACK_CPLXF_TYPE cdblm1 = ARPACK_cplxf(-1.0, 0.0); ++ ARPACK_CPLXF_TYPE cdbl0 = ARPACK_cplxf(0.0, 0.0); ++ ++ n = V->n; // n is constant, this is just for typing convenience ++ ipj = 0; ++ irj = ipj + n; ++ ivj = irj + n; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // Initial call to this routine ++ V->aitr_j = k; ++ V->info = 0; ++ V->aitr_step3 = 0; ++ V->aitr_step4 = 0; ++ V->aitr_orth1 = 0; ++ V->aitr_orth2 = 0; ++ V->aitr_restart = 0; ++ } ++ ++ // When in reverse communication mode one of: ++ // STEP3, STEP4, ORTH1, ORTH2, RSTART ++ // will be .true. when .... ++ // STEP3: return from computing OP*v_{j}. ++ // STEP4: return from computing B-norm of OP*v_{j} ++ // ORTH1: return from computing B-norm of r_{j+1} ++ // ORTH2: return from computing B-norm of ++ // correction to the residual vector. ++ // RSTART: return from OP computations needed by ++ // dgetv0. ++ ++ if (V->aitr_step3) { goto LINE50; } ++ if (V->aitr_step4) { goto LINE60; } ++ if (V->aitr_orth1) { goto LINE70; } ++ if (V->aitr_orth2) { goto LINE90; } ++ if (V->aitr_restart) { goto LINE30; } ++ ++ // Else this is the first step ++ ++ // ++ // A R N O L D I I T E R A T I O N L O O P ++ // ++ // Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) ++ ++LINE1000: ++ ++ // STEP 1: Check if the B norm of j-th residual ++ // vector is zero. Equivalent to determining whether ++ // an exact j-step Arnoldi factorization is present. ++ ++ V->aitr_betaj = *rnorm; ++ if (*rnorm > 0.0) { goto LINE40; } ++ ++ // Invariant subspace found, generate a new starting ++ // vector which is orthogonal to the current Arnoldi ++ // basis and continue the iteration. ++ ++ V->aitr_betaj = 0.0; ++ V->getv0_itry = 1; ++ ++LINE20: ++ V->aitr_restart = 1; ++ V->ido = ido_FIRST; ++ ++LINE30: ++ ++ // If in reverse communication mode and aitr_restart = 1, flow returns here. ++ ++ cgetv0(V, 0, n, V->aitr_j, v, ldv, resid, rnorm, ipntr, workd); ++ ++ if (V->ido != ido_DONE) { return; } ++ V->aitr_ierr = V->info; ++ if (V->aitr_ierr < 0) ++ { ++ V->getv0_itry += 1; ++ if (V->getv0_itry <= 3) { goto LINE20; } ++ ++ // Give up after several restart attempts. ++ // Set INFO to the size of the invariant subspace ++ // which spans OP and exit. ++ ++ V->info = V->aitr_j; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++LINE40: ++ ++ // STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm ++ // Note that p_{j} = B*r_{j-1}. In order to avoid overflow ++ // when reciprocating a small RNORM, test against lower ++ // machine bound. ++ ++ ccopy_(&n, resid, &int1, &v[ldv*V->aitr_j], &int1); ++ ++ if (*rnorm >= unfl) ++ { ++ temp1 = 1.0 / *rnorm; ++ csscal_(&n, &temp1, &v[ldv*V->aitr_j], &int1); ++ csscal_(&n, &temp1, &workd[ipj], &int1); ++ } else { ++ clascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &v[ldv*V->aitr_j], &n, &infol); ++ clascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &workd[ipj], &n, &infol); ++ } ++ ++ // STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} ++ // Note that this is not quite yet r_{j}. See STEP 4 ++ ++ V->aitr_step3 = 1; ++ ccopy_(&n, &v[ldv*(V->aitr_j)], &int1, &workd[ivj], &int1); ++ ipntr[0] = ivj; ++ ipntr[1] = irj; ++ ipntr[2] = ipj; ++ V->ido = ido_OPX; ++ ++ // Exit in order to compute OP*v_{j} ++ ++ return; ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // WORKD(IRJ:IRJ+N-1) := OP*v_{j} ++ // if step3 = .true. ++ ++ V->aitr_step3 = 0; ++ ++ // Put another copy of OP*v_{j} into RESID. ++ ++ ccopy_(&n, &workd[irj], &int1, resid, &int1); ++ ++ // STEP 4: Finish extending the Arnoldi ++ // factorization to length j. ++ ++ if (V->bmat) ++ { ++ V->aitr_step4 = 1; ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*OP*v_{j} ++ ++ return; ++ } else { ++ ccopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE60: ++ ++ // Back from reverse communication; ++ // WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} ++ // if step4 = .true. ++ ++ V->aitr_step4 = 0; ++ ++ // The following is needed for STEP 5. ++ // Compute the B-norm of OP*v_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_wnorm = sqrt(cabsf(cdotc_(&n, resid, &int1, &workd[ipj], &int1))); ++ } else { ++ V->aitr_wnorm = scnrm2_(&n, resid, &int1); ++ } ++ ++ // Compute the j-th residual corresponding ++ // to the j step factorization. ++ // Use Classical Gram Schmidt and compute: ++ // w_{j} <- V_{j}^T * B * OP * v_{j} ++ // r_{j} <- OP*v_{j} - V_{j} * w_{j} ++ ++ // Compute the j Fourier coefficients w_{j} ++ // WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. ++ tmp_int = V->aitr_j + 1; ++ cgemv_("C", &n, &tmp_int, &cdbl1, v, &ldv, &workd[ipj], &int1, &cdbl0, &h[ldh*(V->aitr_j)], &int1); ++ ++ // Orthogonalize r_{j} against V_{j}. ++ // RESID contains OP*v_{j}. See STEP 3. ++ ++ cgemv_("N", &n, &tmp_int, &cdblm1, v, &ldv, &h[ldh*(V->aitr_j)], &int1, &cdbl1, resid, &int1); ++ ++ if (V->aitr_j > 0) { h[V->aitr_j + ldh*(V->aitr_j-1)] = ARPACK_cplxf(V->aitr_betaj, 0.0); } ++ ++ V->aitr_orth1 = 1; ++ if (V->bmat) ++ { ++ ccopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j} ++ ++ return; ++ } else { ++ ccopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE70: ++ ++ // Back from reverse communication if ORTH1 = .true. ++ // WORKD(IPJ:IPJ+N-1) := B*r_{j}. ++ ++ V->aitr_orth1 = 0; ++ ++ // Compute the B-norm of r_{j}. ++ ++ if (V->bmat) ++ { ++ *rnorm = sqrt(cabsf(cdotc_(&n, resid, &int1, &workd[ipj], &int1))); ++ } else { ++ *rnorm = scnrm2_(&n, resid, &int1); ++ } ++ ++ // STEP 5: Re-orthogonalization / Iterative refinement phase ++ // Maximum NITER_ITREF tries. ++ // ++ // s = V_{j}^T * B * r_{j} ++ // r_{j} = r_{j} - V_{j}*s ++ // alphaj = alphaj + s_{j} ++ // ++ // The stopping criteria used for iterative refinement is ++ // discussed in Parlett's book SEP, page 107 and in Gragg & ++ // Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. ++ // Determine if we need to correct the residual. The goal is ++ // to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || ++ // The following test determines whether the sine of the ++ // angle between OP*x and the computed residual is less ++ // than or equal to 0.7071. ++ ++ if (*rnorm > sq2o2*V->aitr_wnorm) { goto LINE100; } ++ V->aitr_iter = 0; ++ ++ // Enter the Iterative refinement phase. If further ++ // refinement is necessary, loop back here. The loop ++ // variable is ITER. Perform a step of Classical ++ // Gram-Schmidt using all the Arnoldi vectors V_{j} ++ ++LINE80: ++ ++ // Compute V_{j}^T * B * r_{j}. ++ // WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). ++ tmp_int = V->aitr_j + 1; ++ cgemv_("C", &n, &tmp_int, &cdbl1, v, &ldv, &workd[ipj], &int1, &cdbl0, &workd[irj], &int1); ++ ++ // Compute the correction to the residual: ++ // r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). ++ // The correction to H is v(:,1:J)*H(1:J,1:J) ++ // + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. ++ ++ cgemv_("N", &n, &tmp_int, &cdblm1, v, &ldv, &workd[irj], &int1, &cdbl1, resid, &int1); ++ caxpy_(&tmp_int, &cdbl1, &workd[irj], &int1, &h[ldh*(V->aitr_j)], &int1); ++ ++ V->aitr_orth2 = 1; ++ ++ if (V->bmat) ++ { ++ ccopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j}. ++ // r_{j} is the corrected residual. ++ ++ return; ++ } else { ++ ccopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE90: ++ ++ // Back from reverse communication if ORTH2 = .true. ++ // Compute the B-norm of the corrected residual r_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_rnorm1 = sqrt(cabsf(cdotc_(&n, resid, &int1, &workd[ipj], &int1))); ++ } else { ++ V->aitr_rnorm1 = scnrm2_(&n, resid, &int1); ++ } ++ ++ // Determine if we need to perform another ++ // step of re-orthogonalization. ++ ++ if (V->aitr_rnorm1 > sq2o2*(*rnorm)) ++ { ++ ++ // No need for further refinement. ++ // The cosine of the angle between the ++ // corrected residual vector and the old ++ // residual vector is greater than 0.717 ++ // In other words the corrected residual ++ // and the old residual vector share an ++ // angle of less than arcCOS(0.717) ++ ++ *rnorm = V->aitr_rnorm1; ++ ++ } else { ++ ++ // Another step of iterative refinement step ++ // is required. ++ ++ *rnorm = V->aitr_rnorm1; ++ V->aitr_iter += 1; ++ if (V->aitr_iter < 2) { goto LINE80; } ++ ++ // Otherwise RESID is numerically in the span of V ++ ++ for (jj = 0; jj < n; jj++) ++ { ++ resid[jj] = ARPACK_cplxf(0.0, 0.0); ++ } ++ *rnorm = 0.0; ++ } ++ ++LINE100: ++ ++ V->aitr_restart = 0; ++ V->aitr_orth2 = 0; ++ ++ // STEP 6: Update j = j+1; Continue ++ ++ V->aitr_j += 1; ++ ++ if (V->aitr_j >= k + np) ++ { ++ V->ido = ido_DONE; ++ for (i = (k > 0 ? k-1 : k); i < k + np - 1; i++) ++ { ++ ++ // Check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine dlahqr ++ ++ tst1 = cabsf(h[i + ldh*i]) + cabsf(h[i+1 + ldh*(i+1)]); ++ if (tst1 == 0.0) ++ { ++ tmp_int = k + np; ++ // clanhs(norm, n, a, lda, work) with "work" being float type ++ // Recasting complex workspace to float for scratch space. ++ tst1 = clanhs_("1", &tmp_int, h, &ldh, (float*)&workd[n]); ++ } ++ if (cabsf(h[i+1 + ldh*i]) <= fmax(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = ARPACK_cplxf(0.0, 0.0); ++ } ++ } ++ // 110 ++ return; ++ } ++ goto LINE1000; ++ ++} ++ ++ ++static void ++cnapps(int n, int* kev, int np, ARPACK_CPLXF_TYPE* shift, ARPACK_CPLXF_TYPE* v, ++ int ldv, ARPACK_CPLXF_TYPE* h, int ldh, ARPACK_CPLXF_TYPE* resid, ++ ARPACK_CPLXF_TYPE* q, int ldq, ARPACK_CPLXF_TYPE* workl, ++ ARPACK_CPLXF_TYPE* workd) ++{ ++ int i, j, jj, int1 = 1, istart, iend = 0, tmp_int; ++ float smlnum = unfl * ( n / ulp); ++ float c, tst1; ++ float tmp_dbl; ++ ARPACK_CPLXF_TYPE f, g, h11, h21, sigma, s, s2, r, t, tmp_cplx; ++ ++ #if defined(_MSC_VER) ++ ARPACK_CPLXF_TYPE tmp_cplx2; ++ #endif ++ ++ ARPACK_CPLXF_TYPE cdbl1 = ARPACK_cplxf(1.0, 0.0); ++ ARPACK_CPLXF_TYPE cdbl0 = ARPACK_cplxf(0.0, 0.0); ++ ++ int kplusp = *kev + np; ++ ++ // Initialize Q to the identity to accumulate ++ // the rotations and reflections ++ claset_("G", &kplusp, &kplusp, &cdbl0, &cdbl1, q, &ldq); ++ ++ // Quick return if there are no shifts to apply ++ ++ if (np == 0) { return; } ++ ++ // Chase the bulge with the application of each ++ // implicit shift. Each shift is applied to the ++ // whole matrix including each block. ++ ++ for (jj = 0; jj < np; jj++) ++ { ++ sigma = shift[jj]; ++ istart = 0; ++ ++ while (istart < kplusp - 1) ++ { ++ for (iend = istart; iend < kplusp - 1; iend++) ++ { ++ tst1 = fabs(crealf(h[iend + ldh*iend])) + fabs(cimagf(h[iend + ldh*iend])) + ++ fabs(crealf(h[iend+1 + ldh*(iend+1)])) + fabs(cimagf(h[iend+1 + ldh*(iend+1)])); ++ if (tst1 == 0.0) ++ { ++ tmp_int = kplusp - jj; ++ clanhs_("1", &tmp_int, h, &ldh, (float*)workl); ++ } ++ if (fabs(crealf(h[iend+1 + ldh*iend])) <= fmax(ulp*tst1, smlnum)) ++ { ++ break; ++ } ++ } ++ if ((istart == iend) || (istart >= *kev)) ++ { ++ ++ // No reason to apply a shift to block of order 1 ++ // or if the current block starts after the point ++ // of compression since we'll discard this stuff. ++ ++ istart += 1; ++ continue; ++ ++ } else if (iend < kplusp - 1) { ++ ++ // Valid block found and it's not the entire remaining array ++ // Clean up the noise ++ ++ h[iend+1 + ldh*iend] = ARPACK_cplxf(0.0, 0.0); ++ } ++ ++ h11 = h[istart + ldh*istart]; ++ h21 = h[istart + 1 + ldh*istart]; ++ // f = h11 - sigma; ++ f = ARPACK_cplxf(crealf(h11)-crealf(sigma), cimagf(h11)-cimagf(sigma)); ++ g = h21; ++ ++ for (i = istart; i < iend; i++) ++ { ++ ++ // Construct the plane rotation G to zero out the bulge ++ ++ clartg_(&f, &g, &c, &s, &r); ++ if (i > istart) ++ { ++ h[i + ldh*(i-1)] = r; ++ h[i + 1 + ldh*(i-1)] = ARPACK_cplxf(0.0, 0.0); ++ } ++ tmp_int = kplusp - i; ++ crot_(&tmp_int, &h[i + ldh*i], &ldh, &h[i + 1 + ldh*i], &ldh, &c, &s); ++ // z = a + bi, -conj(z) = -a + bi ++ s2 = conjf(s); ++ tmp_int = (i + 2 > iend ? iend : i + 2) + 1; ++ crot_(&tmp_int, &h[ldh*i], &int1, &h[ldh*(i+1)], &int1, &c, &s2); ++ tmp_int = (i + jj + 2 > kplusp ? kplusp : i + jj + 2); ++ crot_(&tmp_int, &q[ldq*i], &int1, &q[ldq*(i+1)], &int1, &c, &s2); ++ ++ if (i < iend - 1) ++ { ++ f = h[i + 1 + ldh*i]; ++ g = h[i + 2 + ldh*i]; ++ } ++ } ++ istart = iend + 1; ++ } ++ } ++ ++ // Perform a similarity transformation that makes ++ // sure that H will have non negative sub diagonals ++ ++ for (j = 0; j < *kev; j++) ++ { ++ if ((crealf(h[j+1 + ldh*j]) < 0.0) || (cimagf(h[j+1 + ldh*j]) != 0.0)) ++ { ++ tmp_dbl = cabsf(h[j+1 + ldh*j]); ++ t = ARPACK_cplxf(crealf(h[j+1 + ldh*j]) / tmp_dbl, ++ cimagf(h[j+1 + ldh*j]) / tmp_dbl); ++ ++ tmp_cplx = conjf(t); ++ tmp_int = kplusp - j; ++ cscal_(&tmp_int, &tmp_cplx, &h[j+1 + ldh*j], &ldh); ++ ++ tmp_int = (j+3 > kplusp ? kplusp : j+3); ++ cscal_(&tmp_int, &t, &h[ldh*(j+1)], &int1); ++ ++ tmp_int = (j+np+2 > kplusp ? kplusp : j+np+2); ++ cscal_(&tmp_int, &t, &q[ldq*(j+1)], &int1); ++ ++ h[j+1 + ldh*j] = ARPACK_cplxf(crealf(h[j+1 + ldh*j]), 0.0); ++ } ++ } ++ // 120 ++ ++ for (i = 0; i < *kev; i++) ++ { ++ ++ // Final check for splitting and deflation. ++ // Use a standard test as in the QR algorithm ++ // REFERENCE: LAPACK subroutine zlahqr. ++ // Note: Since the subdiagonals of the ++ // compressed H are nonnegative real numbers, ++ // we take advantage of this. ++ ++ tst1 = fabs(crealf(h[i + ldh*i])) + fabs(crealf(h[i+1 + ldh*(i+1)])) + ++ fabs(cimagf(h[i + ldh*i])) + fabs(cimagf(h[i+1 + ldh*(i+1)])); ++ if (tst1 == 0.0) ++ { ++ tst1 = clanhs_("1", kev, h, &ldh, (float*)workl); ++ } ++ if (crealf(h[i+1 + ldh*i]) <= fmax(ulp*tst1, smlnum)) ++ { ++ h[i+1 + ldh*i] = ARPACK_cplxf(0.0, 0.0); ++ } ++ } ++ // 130 ++ ++ // Compute the (kev+1)-st column of (V*Q) and ++ // temporarily store the result in WORKD(N+1:2*N). ++ // This is needed in the residual update since we ++ // cannot GUARANTEE that the corresponding entry ++ // of H would be zero as in exact arithmetic. ++ ++ if (crealf(h[*kev + ldh*(*kev-1)]) > 0.0) ++ { ++ cgemv_("N", &n, &kplusp, &cdbl1, v, &ldv, &q[(*kev)*ldq], &int1, &cdbl0, &workd[n], &int1); ++ } ++ ++ // Compute column 1 to kev of (V*Q) in backward order ++ // taking advantage of the upper Hessenberg structure of Q. ++ ++ for (i = 0; i < *kev; i++) ++ { ++ tmp_int = kplusp - i; ++ cgemv_("N", &n, &tmp_int, &cdbl1, v, &ldv, &q[(*kev-i-1)*ldq], &int1, &cdbl0, workd, &int1); ++ ccopy_(&n, workd, &int1, &v[(kplusp-i-1)*ldv], &int1); ++ } ++ ++ // Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). ++ ++ clacpy_("A", &n, kev, &v[ldv*(kplusp - *kev)], &ldv, v, &ldv); ++ ++ // Copy the (kev+1)-st column of (V*Q) in the appropriate place ++ ++ if (crealf(h[*kev + ldh*(*kev-1)]) > 0.0) { ++ ccopy_(&n, &workd[n], &int1, &v[ldv*(*kev)], &int1); ++ } ++ ++ // Update the residual vector: ++ // r <- sigmak*r + betak*v(:,kev+1) ++ // where ++ // sigmak = (e_{kplusp}'*Q)*e_{kev} ++ // betak = e_{kev+1}'*H*e_{kev} ++ ++ cscal_(&n, &q[kplusp-1 + ldq*(*kev-1)], resid, &int1); ++ ++ if (crealf(h[*kev + ldh*(*kev-1)]) > 0.0) ++ { ++ caxpy_(&n, &h[*kev + ldh*(*kev-1)], &v[ldv*(*kev)], &int1, resid, &int1); ++ } ++ ++ return; ++} ++ ++ ++static void ++cneigh(float* rnorm, int n, ARPACK_CPLXF_TYPE* h, int ldh, ARPACK_CPLXF_TYPE* ritz, ++ ARPACK_CPLXF_TYPE* bounds, ARPACK_CPLXF_TYPE* q, int ldq, ARPACK_CPLXF_TYPE* workl, ++ float* rwork, int* ierr) ++{ ++ int select[1] = { 0 }; ++ int int1 = 1, j; ++ float temp; ++ ARPACK_CPLXF_TYPE vl[1] = { 0.0 }; ++ ARPACK_CPLXF_TYPE c1 = ARPACK_cplxf(1.0, 0.0), c0 = ARPACK_cplxf(0.0, 0.0); ++ ++ // 1. Compute the eigenvalues, the last components of the ++ // corresponding Schur vectors and the full Schur form T ++ // of the current upper Hessenberg matrix H. ++ // zlahqr returns the full Schur form of H ++ // in WORKL(1:N**2), and the Schur vectors in q. ++ ++ clacpy_("A", &n, &n, h, &ldh, workl, &n); ++ claset_("A", &n, &n, &c0, &c1, q, &ldq); ++ clahqr_(&int1, &int1, &n, &int1, &n, workl, &ldh, ritz, &int1, &n, q, &ldq, ierr); ++ ++ if (*ierr != 0) { return; } ++ ++ ccopy_(&n, &q[n-2], &ldq, bounds, &int1); ++ ++ // 2. Compute the eigenvectors of the full Schur form T and ++ // apply the Schur vectors to get the corresponding ++ // eigenvectors. ++ ++ ctrevc_("R", "B", select, &n, workl, &n, vl, &n, q, &ldq, &n, &n, &workl[n*n], rwork, ierr); ++ ++ if (*ierr != 0) { return; } ++ ++ // Scale the returning eigenvectors so that their ++ // euclidean norms are all one. LAPACK subroutine ++ // ztrevc returns each eigenvector normalized so ++ // that the element of largest magnitude has ++ // magnitude 1; here the magnitude of a complex ++ // number (x,y) is taken to be |x| + |y|. ++ ++ for (j = 0; j < n; j++) ++ { ++ temp = 1.0 / scnrm2_(&n, &q[j*ldq], &int1); ++ csscal_(&n, &temp, &q[j*ldq], &int1); ++ } ++ ++ // Compute the Ritz estimates ++ ++ ccopy_(&n, &q[n-1], &n, bounds, &int1); ++ csscal_(&n, rnorm, bounds, &int1); ++ ++ return; ++} ++ ++ ++void ++cngets(struct ARPACK_arnoldi_update_vars_s *V, int* kev, int* np, ++ ARPACK_CPLXF_TYPE* ritz, ARPACK_CPLXF_TYPE* bounds) ++{ ++ ++ csortc(V->which, 1, *kev + *np, ritz, bounds); ++ ++ if (V->shift == 1) ++ { ++ ++ // Sort the unwanted Ritz values used as shifts so that ++ // the ones with largest Ritz estimates are first ++ // This will tend to minimize the effects of the ++ // forward instability of the iteration when they shifts ++ // are applied in subroutine znapps. ++ // Be careful and use 'SM' since we want to sort BOUNDS! ++ ++ csortc(which_SM, 1, *np, bounds, ritz); ++ } ++ ++ return; ++} ++ ++ ++static void ++cgetv0(struct ARPACK_arnoldi_update_vars_s *V, int initv, int n, int j, ++ ARPACK_CPLXF_TYPE* v, int ldv, ARPACK_CPLXF_TYPE* resid, float* rnorm, ++ int* ipntr, ARPACK_CPLXF_TYPE* workd) ++{ ++ int jj, int1 = 1; ++ const float sq2o2 = sqrt(2.0) / 2.0; ++ ARPACK_CPLXF_TYPE c0 = ARPACK_cplxf(0.0, 0.0); ++ ARPACK_CPLXF_TYPE c1 = ARPACK_cplxf(1.0, 0.0); ++ ARPACK_CPLXF_TYPE cm1 = ARPACK_cplxf(-1.0, 0.0); ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->info = 0; ++ V->getv0_iter = 0; ++ V->getv0_first = 0; ++ V->getv0_orth = 0; ++ ++ // Possibly generate a random starting vector in RESID ++ // Skip if this the return of ido_RANDOM. ++ ++ if (!(initv)) ++ { ++ // Request a random vector from the user into resid ++ V->ido = ido_RANDOM; ++ return; ++ } else { ++ // If initv = 1, then the user has provided a starting vector ++ // in RESID. We need to copy it into workd[n] and perform an OP(x0). ++ // Change the ido but don't exit to join back to the flow. ++ V->ido = ido_RANDOM; ++ } ++ } ++ ++ // Back from random vector generation ++ if (V->ido == ido_RANDOM) ++ { ++ // Force the starting vector into the range of OP to handle ++ // the generalized problem when B is possibly (singular). ++ ++ if (V->getv0_itry == 1) ++ { ++ ipntr[0] = 0; ++ ipntr[1] = n; ++ ccopy_(&n, resid, &int1, workd, &int1); ++ V->ido = ido_RANDOM_OPX; ++ return; ++ } else if ((V->getv0_itry > 1) && (V->bmat == 1)) ++ { ++ ccopy_(&n, resid, &int1, &workd[n], &int1); ++ } ++ } ++ ++ // Back from computing OP*(initial-vector) ++ ++ if (V->getv0_first) { goto LINE20; } ++ ++ // Back from computing OP*(orthogonalized-vector) ++ ++ if (V->getv0_orth) { goto LINE40; } ++ ++ // Starting vector is now in the range of OP; r = OP*r; ++ // Compute B-norm of starting vector. ++ ++ V->getv0_first = 1; ++ if (V->getv0_itry == 1) ++ { ++ ccopy_(&n, &workd[n], &int1, resid, &int1); ++ } ++ if (V->bmat) ++ { ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ ccopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE20: ++ ++ V->getv0_first = 0; ++ if (V->bmat) ++ { ++ V->getv0_rnorm0 = sqrt(cabsf(cdotc_(&n, resid, &int1, workd, &int1))); ++ } else { ++ V->getv0_rnorm0 = scnrm2_(&n, resid, &int1); ++ } ++ *rnorm = V->getv0_rnorm0; ++ ++ // Exit if this is the very first Arnoldi step ++ ++ if (j == 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Otherwise need to B-orthogonalize the starting vector against ++ // the current Arnoldi basis using Gram-Schmidt with iter. ref. ++ // This is the case where an invariant subspace is encountered ++ // in the middle of the Arnoldi factorization. ++ // ++ // s = V^{T}*B*r; r = r - V*s; ++ // ++ // Stopping criteria used for iter. ref. is discussed in ++ // Parlett's book, page 107 and in Gragg & Reichel TOMS paper. ++ ++ V->getv0_orth = 1; ++ ++LINE30: ++ ++ cgemv_("C", &n, &j, &c1, v, &ldv, workd, &int1, &c0, &workd[n], &int1); ++ cgemv_("N", &n, &j, &cm1, v, &ldv, &workd[n], &int1, &c1, resid, &int1); ++ ++ // Compute the B-norm of the orthogonalized starting vector ++ ++ if (V->bmat) ++ { ++ ccopy_(&n, resid, &int1, &workd[n], &int1); ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ ccopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE40: ++ if (V->bmat) ++ { ++ *rnorm = sqrt(cabsf(cdotc_(&n, resid, &int1, workd, &int1))); ++ } else { ++ *rnorm = scnrm2_(&n, resid, &int1); ++ } ++ ++ // Check for further orthogonalization. ++ ++ if (*rnorm > sq2o2*V->getv0_rnorm0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->getv0_iter += 1; ++ ++ if (V->getv0_iter < 2) ++ { ++ ++ // Perform iterative refinement step ++ ++ V->getv0_rnorm0 = *rnorm; ++ goto LINE30; ++ } else { ++ ++ // Iterative refinement step "failed" ++ ++ for (jj = 0; jj < n; jj++) { resid[jj] = ARPACK_cplxf(0.0, 0.0); } ++ *rnorm = 0.0; ++ V->info = -1; ++ } ++ ++ V->ido = ido_DONE; ++ return; ++} ++ ++ ++void ++csortc(const enum ARPACK_which w, const int apply, const int n, ARPACK_CPLXF_TYPE *x, ARPACK_CPLXF_TYPE *y) ++{ ++ int i, igap, j; ++ ARPACK_CPLXF_TYPE temp; ++ ARPACK_compare_cfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortc_LM; ++ break; ++ case which_SM: ++ f = sortc_SM; ++ break; ++ case which_LR: ++ f = sortc_LR; ++ break; ++ case which_LI: ++ f = sortc_LI; ++ break; ++ case which_SR: ++ f = sortc_SR; ++ break; ++ case which_SI: ++ f = sortc_SI; ++ break; ++ default: ++ f = sortc_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(x[j], x[j+igap])) ++ { ++ if (j < 0) { break; } ++ temp = x[j]; ++ x[j] = x[j+igap]; ++ x[j+igap] = temp; ++ ++ if (apply) ++ { ++ temp = y[j]; ++ y[j] = y[j+igap]; ++ y[j+igap] = temp; ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++} ++ ++ ++static int sortc_LM(const ARPACK_CPLXF_TYPE x, const ARPACK_CPLXF_TYPE y) { return (cabsf(x) > cabsf(y)); } ++static int sortc_SM(const ARPACK_CPLXF_TYPE x, const ARPACK_CPLXF_TYPE y) { return (cabsf(x) < cabsf(y)); } ++static int sortc_LR(const ARPACK_CPLXF_TYPE x, const ARPACK_CPLXF_TYPE y) { return (crealf(x) > crealf(y)); } ++static int sortc_SR(const ARPACK_CPLXF_TYPE x, const ARPACK_CPLXF_TYPE y) { return (crealf(x) < crealf(y)); } ++static int sortc_LI(const ARPACK_CPLXF_TYPE x, const ARPACK_CPLXF_TYPE y) { return (cimagf(x) > cimagf(y)); } ++static int sortc_SI(const ARPACK_CPLXF_TYPE x, const ARPACK_CPLXF_TYPE y) { return (cimagf(x) < cimagf(y)); } ++ ++ ++// cdotc is the complex conjugate dot product of two complex vectors. ++// Due some historical reasons, this function can cause segfaults on some ++// platforms. Hence implemented here instead of using the BLAS version. ++static ARPACK_CPLXF_TYPE ++cdotc_(const int* n, const ARPACK_CPLXF_TYPE* restrict x, const int* incx, const ARPACK_CPLXF_TYPE* restrict y, const int* incy) ++{ ++ ARPACK_CPLXF_TYPE result = ARPACK_cplxf(0.0, 0.0); ++#ifdef _MSC_VER ++ ARPACK_CPLXF_TYPE temp = ARPACK_cplxf(0.0, 0.0); ++#endif ++ if (*n <= 0) { return result; } ++ if ((*incx == 1) && (*incy == 1)) ++ { ++ for (int i = 0; i < *n; i++) ++ { ++#ifdef _MSC_VER ++ temp = _FCmulcc(x[i], conjf(y[i])); ++ result = ARPACK_cplxf(crealf(result) + crealf(temp), cimagf(result) + cimagf(temp)); ++#else ++ result = result + (x[i] * conjf(y[i])); ++#endif ++ } ++ ++ } else { ++ ++ for (int i = 0; i < *n; i++) ++ { ++#ifdef _MSC_VER ++ temp = _FCmulcc(x[i * (*incx)], conjf(y[i * (*incy)])); ++ result = ARPACK_cplxf(crealf(result) + crealf(temp), cimagf(result) + cimagf(temp)); ++#else ++ result = result + (x[i * (*incx)] * conjf(y[i * (*incy)])); ++#endif ++ } ++ } ++ ++ return result; ++} +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.h +new file mode 100644 +index 0000000000..b4d48de2ed +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_n_single_complex.h +@@ -0,0 +1,45 @@ ++#ifndef _ARPACK_N_SINGLE_COMPLEX_H ++#define _ARPACK_N_SINGLE_COMPLEX_H ++ ++#include "_arpack.h" ++ ++// BLAS Routines used ++void caxpy_(int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* x, int* incx, ARPACK_CPLXF_TYPE* y, int* incy); ++void ccopy_(int* n, ARPACK_CPLXF_TYPE* x, int* incx, ARPACK_CPLXF_TYPE* y, int* incy); ++void cgeru_(int* m, int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* x, int* incx, ARPACK_CPLXF_TYPE* y, int* incy, ARPACK_CPLXF_TYPE* a, int* lda); ++float scnrm2_(int* n, ARPACK_CPLXF_TYPE* x, int* incx); ++void cscal_(int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* x, int* incx); ++void csscal_(int* n, float* da, ARPACK_CPLXF_TYPE* zx, int* incx); ++void cgemv_(char* trans, int* m, int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* a, int* lda, ARPACK_CPLXF_TYPE* x, int* incx, ARPACK_CPLXF_TYPE* beta, ARPACK_CPLXF_TYPE* y, int* incy); ++void crot_(int* n, ARPACK_CPLXF_TYPE* cx, int* incx, ARPACK_CPLXF_TYPE* cy, int* incy, float* c, ARPACK_CPLXF_TYPE* s); ++void ctrmm_(char* side, char* uplo, char* transa, char* diag, int* m, int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* a, int* lda, ARPACK_CPLXF_TYPE* b, int* ldb); ++ ++// LAPACK Routines used ++void cgeqr2_(int* m, int* n, ARPACK_CPLXF_TYPE* a, int* lda, ARPACK_CPLXF_TYPE* tau, ARPACK_CPLXF_TYPE* work, int* info); ++void clacpy_(char* uplo, int* m, int* n, ARPACK_CPLXF_TYPE* a, int* lda, ARPACK_CPLXF_TYPE* b, int* ldb); ++void clahqr_(int* wantt, int* wantz, int* n, int* ilo, int* ihi, ARPACK_CPLXF_TYPE* h, int* ldh, ARPACK_CPLXF_TYPE* w, int* iloz, int* ihiz, ARPACK_CPLXF_TYPE* z, int* ldz, int* info ); ++float clanhs_(char* norm, int* n, ARPACK_CPLXF_TYPE* a, int* lda, float* work); ++void clarf_(char* side, int* m, int* n, ARPACK_CPLXF_TYPE* v, int* incv, ARPACK_CPLXF_TYPE* tau, ARPACK_CPLXF_TYPE* c, int* ldc, ARPACK_CPLXF_TYPE* work); ++void clarfg_(int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* x, int* incx, ARPACK_CPLXF_TYPE* tau); ++void clartg_(ARPACK_CPLXF_TYPE* f, ARPACK_CPLXF_TYPE* g, float* c, ARPACK_CPLXF_TYPE* s, ARPACK_CPLXF_TYPE* r); ++void clascl_(char* mtype, int* kl, int* ku, float* cfrom, float* cto, int* m, int* n, ARPACK_CPLXF_TYPE* a, int* lda, int* info); ++void claset_(char* uplo, int* m, int* n, ARPACK_CPLXF_TYPE* alpha, ARPACK_CPLXF_TYPE* beta, ARPACK_CPLXF_TYPE* a, int* lda); ++void ctrevc_(char* side, char* howmny, int* select, int* n, ARPACK_CPLXF_TYPE* t, int* ldt, ARPACK_CPLXF_TYPE* vl, int* ldvl, ARPACK_CPLXF_TYPE* vr, int* ldvr, int* mm, int* m, ARPACK_CPLXF_TYPE* work, float* rwork, int* info); ++void ctrsen_(char* job, char* compq, int* select, int* n, ARPACK_CPLXF_TYPE* t, int* ldt, ARPACK_CPLXF_TYPE* q, int* ldq, ARPACK_CPLXF_TYPE* w, int* m, float* s, float* sep, ARPACK_CPLXF_TYPE* work, int* lwork, int* info); ++void cunm2r_(char* side, char* trans, int* m, int* n, int* k, ARPACK_CPLXF_TYPE* a, int* lda, ARPACK_CPLXF_TYPE* tau, ARPACK_CPLXF_TYPE* c, int* ldc, ARPACK_CPLXF_TYPE* work, int* info); ++ ++#if defined(_MSC_VER) ++ // MSVC definitions ++ #include // MSVC C++ header ++ typedef _Fcomplex ARPACK_CPLXF_TYPE; ++ #define ARPACK_cplxf(real, imag) ((_Fcomplex){real, imag}) ++ ++#else ++ // C99 compliant compilers ++ #include ++ typedef float complex ARPACK_CPLXF_TYPE; ++ #define ARPACK_cplxf(real, imag) ((real) + (imag)*I) ++ ++#endif ++ ++#endif +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.c b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.c +new file mode 100644 +index 0000000000..e0cf5a9595 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.c +@@ -0,0 +1,2238 @@ ++#include "_arpack_s_double.h" ++ ++typedef int ARPACK_compare_rfunc(const double, const double); ++ ++static int sortr_LM(const double, const double); ++static int sortr_SM(const double, const double); ++static int sortr_LA(const double, const double); ++static int sortr_SA(const double, const double); ++ ++static const double unfl = 2.2250738585072014e-308; ++static const double ulp = 2.220446049250313e-16; ++ ++static void dsaup2(struct ARPACK_arnoldi_update_vars_d*, double*, double*, int, double*, int, double*, double*, double*, int, double*, int*, double*); ++static void dsconv(int, double*, double*, double, int*); ++static void dseigt(double, int, double*, int, double*, double*, double*, int*); ++static void dsaitr(struct ARPACK_arnoldi_update_vars_d*, int, int, double*, double*, double*, int, double*, int, int*, double*); ++static void dsapps(int, int*, int, double*, double*, int, double*, int, double*, double* , int, double*); ++static void dsgets(struct ARPACK_arnoldi_update_vars_d*, int*, int*, double*, double*, double*); ++static void dgetv0(struct ARPACK_arnoldi_update_vars_d *, int, int, int, double*, int, double*, double*, int*, double*); ++static void dsortr(const enum ARPACK_which w, const int apply, const int n, double* x1, double* x2); ++static void dsesrt(const enum ARPACK_which w, const int apply, const int n, double* x, int na, double* a, const int lda); ++static void dstqrb(int n, double* d, double* e, double* z, double* work, int* info); ++ ++enum ARPACK_seupd_type { ++ REGULAR, ++ SHIFTI, ++ BUCKLE, ++ CAYLEY ++}; ++ ++ ++void ++ARPACK_dseupd(struct ARPACK_arnoldi_update_vars_d *V, int rvec, int howmny, int* select, ++ double* d, double* z, int ldz, double sigma, double* resid, double* v, ++ int ldv, int* ipntr, double* workd, double* workl) ++{ ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ int j, jj, k; ++ int ibd, ih, ihb, ihd, iq, irz, iw, ldh, ldq, ritz, bounds, next, np; ++ int ierr = 0, int1 = 1, tmp_int = 0, numcnv, reord; ++ double bnorm2, rnorm, temp, temp1, dbl1 = 1.0; ++ ++ if (V->nconv == 0) { return; } ++ ++ ierr = 0; ++ enum ARPACK_seupd_type TYP = REGULAR; ++ ++ if (V->nconv <= 0) { ++ ierr = -14; ++ } else if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv <= V->nev) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if ((V->which != 0) && ++ (V->which != 1) && ++ (V->which != 6) && ++ (V->which != 7) && ++ (V->which != 8)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((rvec) && ((howmny < 0) || (howmny > 2))) { ++ ierr = -15; ++ } else if ((rvec) && (howmny == 2)) { ++ ierr = -16; // NotImplementedError ++ } ++ ++ if ((V->mode == 1) || (V->mode == 2)) { ++ TYP = REGULAR; ++ } else if (V->mode == 3) { ++ TYP = SHIFTI; ++ } else if (V->mode == 4) { ++ TYP = BUCKLE; ++ } else if (V->mode == 5) { ++ TYP = CAYLEY; ++ } else { ++ ierr = -10; ++ } ++ ++ if ((V->mode == 1) && (V->bmat)) { ierr = -11; } ++ if ((V->nev == 1) && (V->which == which_BE)) { ierr = -12; } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ return; ++ } ++ ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:2*ncv) := generated tridiagonal matrix H ++ // The subdiagonal is stored in workl(2:ncv). ++ // The dead spot is workl(1) but upon exiting ++ // dsaupd stores the B-norm of the last residual ++ // vector in workl(1). We use this !!! ++ // workl(2*ncv+1:2*ncv+ncv) := ritz values ++ // The wanted values are in the first NCONV spots. ++ // workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates ++ // The wanted values are in the first NCONV spots. ++ // NOTE: workl(1:4*ncv) is set by dsaupd and is not ++ // modified by dseupd . ++ // ---------------------------------------------------- ++ // The following is used and set by dseupd . ++ // workl(4*ncv+1:4*ncv+ncv) := used as workspace during ++ // computation of the eigenvectors of H. Stores ++ // the diagonal of H. Upon EXIT contains the NCV ++ // Ritz values of the original system. The first ++ // NCONV spots have the wanted values. If MODE = ++ // 1 or 2 then will equal workl(2*ncv+1:3*ncv). ++ // workl(5*ncv+1:5*ncv+ncv) := used as workspace during ++ // computation of the eigenvectors of H. Stores ++ // the subdiagonal of H. Upon EXIT contains the ++ // NCV corresponding Ritz estimates of the ++ // original system. The first NCONV spots have the ++ // wanted values. If MODE = 1,2 then will equal ++ // workl(3*ncv+1:4*ncv). ++ // workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is ++ // the eigenvector matrix for H as returned by ++ // dsteqr . Not referenced if RVEC = .False. ++ // Ordering follows that of workl(4*ncv+1:5*ncv) ++ // workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := ++ // Workspace. Needed by dsteqr and by dseupd . ++ // GRAND total of NCV*(NCV+8) locations. ++ ++ ih = ipntr[4]; ++ ritz = ipntr[5]; ++ bounds = ipntr[6]; ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ihd = bounds + ldh; ++ ihb = ihd + ldh; ++ iq = ihb + ldh; ++ iw = iq + ldh*V->ncv; ++ next = iw + 2*V->ncv; ++ ipntr[3] = next; ++ ipntr[7] = ihd; ++ ipntr[8] = ihb; ++ ipntr[9] = iq; ++ ++ // irz points to the Ritz values computed ++ // by _seigt before exiting _saup2. ++ // ibd points to the Ritz estimates ++ // computed by _seigt before exiting ++ // _saup2. ++ ++ irz = ipntr[10] + V->ncv; ++ ibd = irz + V->ncv; ++ ++ // RNORM is B-norm of the RESID(1:N). ++ // BNORM2 is the 2 norm of B*RESID(1:N). ++ // Upon exit of dsaupd WORKD(1:N) has ++ // B*RESID(1:N). ++ ++ rnorm = workl[ih]; ++ if (V->bmat) ++ { ++ bnorm2 = dnrm2_(&V->n, workd, &int1); ++ } else { ++ bnorm2 = rnorm; ++ } ++ ++ if (rvec) { ++ reord = 0; ++ ++ // Use the temporary bounds array to store indices ++ // These will be used to mark the select array later ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[bounds + j] = j; ++ select[j] = 0; ++ } ++ // 10 ++ ++ // Select the wanted Ritz values. ++ // Sort the Ritz values so that the ++ // wanted ones appear at the tailing ++ // NEV positions of workl(irr) and ++ // workl(iri). Move the corresponding ++ // error estimates in workl(bound) ++ // accordingly. ++ ++ np = V->ncv - V->nev; ++ V->shift = 0; ++ dsgets(V, &V->nev, &np, &workl[irz], &workl[bounds], workl); ++ ++ // Record indices of the converged wanted Ritz values ++ // Mark the select array for possible reordering ++ ++ numcnv = 0; ++ for (j = 1; j <= V->ncv; j++) ++ { ++ temp1 = fmax(eps23, fabs(workl[irz + V->ncv - j])); ++ ++ jj = (int)workl[bounds + V->ncv - j]; ++ ++ if ((numcnv < V->nconv) && (workl[ibd + jj] <= V->tol*temp1)) ++ { ++ select[jj] = 1; ++ numcnv += 1; ++ if (jj > V->nconv - 1) { reord = 1; } ++ } ++ } ++ // 11 ++ ++ // Check the count (numcnv) of converged Ritz values with ++ // the number (nconv) reported by saupd. If these two ++ // are different then there has probably been an error ++ // caused by incorrect passing of the saupd data. ++ ++ if (numcnv != V->nconv) ++ { ++ V->info = -17; ++ return; ++ } ++ ++ // Call LAPACK routine _steqr to compute the eigenvalues and ++ // eigenvectors of the final symmetric tridiagonal matrix H. ++ // Initialize the eigenvector matrix Q to the identity. ++ ++ tmp_int = V->ncv - 1; ++ dcopy_(&tmp_int, &workl[ih+1], &int1, &workl[ihb], &int1); ++ dcopy_(&V->ncv, &workl[ih+ldh], &int1, &workl[ihd], &int1); ++ ++ dsteqr_("I", &V->ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, &workl[iw], &ierr); ++ ++ if (ierr != 0) ++ { ++ V->info = -8; ++ return; ++ } ++ ++ if (reord) ++ { ++ ++ // Reordered the eigenvalues and eigenvectors ++ // computed by _steqr so that the "converged" ++ // eigenvalues appear in the first NCONV ++ // positions of workl(ihd), and the associated ++ // eigenvectors appear in the first NCONV ++ // columns. ++ ++ int leftptr = 0; ++ int rightptr = V->ncv - 1; ++ ++ if (V->ncv > 1) ++ { ++ do ++ { ++ if (select[leftptr]) ++ { ++ ++ // Search, from the left, for the first non-converged Ritz value. ++ ++ leftptr += 1; ++ ++ } else if (!(select[rightptr])) { ++ ++ // Search, from the right, the first converged Ritz value ++ ++ rightptr -= 1; ++ ++ } else { ++ ++ // Swap the Ritz value on the left that has not ++ // converged with the Ritz value on the right ++ // that has converged. Swap the associated ++ // eigenvector of the tridiagonal matrix H as ++ // well. ++ ++ temp = workl[ihd + leftptr]; ++ workl[ihd + leftptr] = workl[ihd + rightptr]; ++ workl[ihd + rightptr] = temp; ++ ++ dcopy_(&V->ncv, &workl[iq + V->ncv*leftptr], &int1, &workl[iw], &int1); ++ dcopy_(&V->ncv, &workl[iq + V->ncv*rightptr], &int1, &workl[iq + V->ncv*leftptr], &int1); ++ dcopy_(&V->ncv, &workl[iw], &int1, &workl[iq + V->ncv*rightptr], &int1); ++ ++ leftptr += 1; ++ rightptr -= 1; ++ } ++ } while (leftptr < rightptr); ++ } ++ } ++ ++ // Load the converged Ritz values into D. ++ ++ dcopy_(&V->nconv, &workl[ihd], &int1, d, &int1); ++ ++ } else { ++ ++ // Ritz vectors not required. Load Ritz values into D. ++ ++ dcopy_(&V->nconv, &workl[ritz], &int1, d, &int1); ++ dcopy_(&V->ncv, &workl[ritz], &int1, &workl[ihd], &int1); ++ } ++ ++ // Transform the Ritz values and possibly vectors and corresponding ++ // Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values ++ // (and corresponding data) are returned in ascending order. ++ ++ if (TYP == REGULAR) ++ { ++ ++ // Ascending sort of wanted Ritz values, vectors and error ++ // bounds. Not necessary if only Ritz values are desired. ++ ++ if (rvec) { ++ dsesrt(which_LA, rvec, V->nconv, d, V->ncv, &workl[iq], ldq); ++ } else { ++ dcopy_(&V->ncv, &workl[bounds], &int1, &workl[ihb], &int1); ++ } ++ ++ } else { ++ ++ // * Make a copy of all the Ritz values. ++ // * Transform the Ritz values back to the original system. ++ // For TYPE = 'SHIFTI' the transformation is ++ // lambda = 1/theta + sigma ++ // For TYPE = 'BUCKLE' the transformation is ++ // lambda = sigma * theta / ( theta - 1 ) ++ // For TYPE = 'CAYLEY' the transformation is ++ // lambda = sigma * (theta + 1) / (theta - 1 ) ++ // where the theta are the Ritz values returned by dsaupd. ++ // NOTES: ++ // *The Ritz vectors are not affected by the transformation. ++ // They are only reordered. ++ ++ dcopy_(&V->ncv, &workl[ihd], &int1, &workl[iw], &int1); ++ if (TYP == SHIFTI) ++ { ++ for (int k = 0; k < V->ncv; k++) ++ { ++ workl[ihd + k] = 1.0 / workl[ihd + k] + sigma; ++ } ++ } else if (TYP == BUCKLE) { ++ for (int k = 0; k < V->ncv; k++) { ++ workl[ihd + k] = sigma * workl[ihd + k] / (workl[ihd + k] - 1.0); ++ } ++ } else if (TYP == CAYLEY) { ++ for (int k = 0; k < V->ncv; k++) { ++ workl[ihd + k] = sigma * (workl[ihd + k] + 1.0) / (workl[ihd + k] - 1.0); ++ } ++ } ++ ++ // * Store the wanted NCONV lambda values into D. ++ // * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) ++ // into ascending order and apply sort to the NCONV theta ++ // values in the transformed system. We will need this to ++ // compute Ritz estimates in the original system. ++ // * Finally sort the lambda`s into ascending order and apply ++ // to Ritz vectors if wanted. Else just sort lambda`s into ++ // ascending order. ++ // NOTES: ++ // *workl(iw:iw+ncv-1) contain the theta ordered so that they ++ // match the ordering of the lambda. We`ll use them again for ++ // Ritz vector purification. ++ ++ dcopy_(&V->nconv, &workl[ihd], &int1, d, &int1); ++ dsortr(which_LA, 1, V->nconv, &workl[ihd], &workl[iw]); ++ if (rvec) { ++ dsesrt(which_LA, rvec, V->nconv, d, V->ncv, &workl[iq], ldq); ++ } else { ++ dcopy_(&V->ncv, &workl[bounds], &int1, &workl[ihb], &int1); ++ temp = bnorm2 / rnorm; ++ dscal_(&V->ncv, &temp, &workl[ihb], &int1); ++ dsortr(which_LA, 1, V->nconv, d, &workl[ihb]); ++ } ++ } ++ ++ // Compute the Ritz vectors. Transform the wanted ++ // eigenvectors of the symmetric tridiagonal H by ++ // the Lanczos basis matrix V. ++ ++ if ((rvec) && (howmny == 0)) ++ { ++ ++ // Compute the QR factorization of the matrix representing ++ // the wanted invariant subspace located in the first NCONV ++ // columns of workl(iq, ldq). ++ ++ dgeqr2_(&V->ncv, &V->nconv, &workl[iq], &ldq, &workl[iw + V->ncv], &workl[ihb], &ierr); ++ ++ // * Postmultiply V by Q. ++ // * Copy the first NCONV columns of VQ into Z. ++ // The N by NCONV matrix Z is now a matrix representation ++ // of the approximate invariant subspace associated with ++ // the Ritz values in workl(ihd). ++ ++ dorm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[iq], &ldq, &workl[iw + V->ncv], v, &ldv, &workd[V->n], &ierr); ++ dlacpy_("A", &V->n, &V->nconv, v, &ldv, z, &ldz); ++ ++ // In order to compute the Ritz estimates for the Ritz ++ // values in both systems, need the last row of the ++ // eigenvector matrix. Remember, it's in factored form. ++ ++ for (int j = 0; j < V->ncv - 1; j++) ++ { ++ workl[ihb + j] = 0.0; ++ } ++ workl[ihb + V->ncv - 1] = 1.0; ++ dorm2r_("L", "T", &V->ncv, &int1, &V->nconv, &workl[iq], &ldq, &workl[iw + V->ncv], &workl[ihb], &V->ncv, &temp, &ierr); ++ ++ // Make a copy of the last row into ++ // workl(iw+ncv:iw+2*ncv), as it is needed again in ++ // the Ritz vector purification step below ++ ++ for (int j = 0; j < V->nconv; j++) ++ { ++ workl[iw + V->ncv + j] = workl[ihb + j]; ++ } ++ // 67 ++ ++ } else if ((rvec) && (howmny == 2)) { ++ // Not yet implemented ++ ; ++ } ++ ++ if ((TYP == REGULAR) && (rvec)) ++ { ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[ihb + j] = rnorm * fabs(workl[ihb + j]); ++ } ++ ++ } else if ((TYP != REGULAR) && (rvec)) { ++ ++ // * Determine Ritz estimates of the theta. ++ // If RVEC = .true. then compute Ritz estimates ++ // of the theta. ++ // If RVEC = .false. then copy Ritz estimates ++ // as computed by dsaupd . ++ // * Determine Ritz estimates of the lambda. ++ ++ ++ dscal_(&V->ncv, &bnorm2, &workl[ihb], &int1); ++ ++ for (k = 0; k < V->ncv; k++) ++ { ++ if (TYP == SHIFTI) ++ { ++ workl[ihb + k] = fabs(workl[ihb + k]) / pow(workl[iw + k], 2.0); ++ } else if (TYP == BUCKLE) { ++ workl[ihb + k] = sigma * fabs(workl[ihb + k]) / pow(workl[iw + k] - 1.0, 2.0); ++ } else if (TYP == CAYLEY) { ++ workl[ihb + k] = fabs(workl[ihb + k] / workl[iw + k] * (workl[iw + k] - 1.0)); ++ } ++ } ++ // 80, 90, 100 ++ } ++ ++ // Ritz vector purification step. Formally perform ++ // one of inverse subspace iteration. Only used ++ // for MODE = 3,4,5. See reference 7 ++ ++ if ((rvec) && ((TYP == SHIFTI) || (TYP == CAYLEY))) ++ { ++ for (k = 0; k < V->nconv; k++) ++ { ++ workl[iw + k] = workl[iw + V->ncv + k] / workl[iw + k]; ++ } ++ // 110 ++ } else if ((rvec) && (TYP == BUCKLE)) ++ { ++ for (k = 0; k < V->nconv; k++) ++ { ++ workl[iw + k] = workl[iw + V->ncv + k] / (workl[iw + k] - 1.0); ++ } ++ // 120 ++ } ++ ++ if ((rvec) && (TYP != REGULAR)) ++ { ++ dger_(&V->n, &V->nconv, &dbl1, resid, &int1, &workl[iw], &int1, z, &ldz); ++ } ++ ++ return; ++} ++ ++ ++void ++ARPACK_dsaupd(struct ARPACK_arnoldi_update_vars_d *V, double* resid, double* v, int ldv, ++ int* ipntr, double* workd, double* workl) ++{ ++ ++ int bounds = 0, ih = 0, iq = 0, iw = 0, j = 0, ldh = 0, ldq = 0, next = 0, ritz = 0; ++ ++ if (V->ido == ido_FIRST) ++ { ++ if (V->n <= 0) { ++ V->info = -1; ++ } else if (V->nev <= 0) { ++ V->info = -2; ++ } else if ((V->ncv < V->nev + 1) || (V->ncv > V->n)) { ++ V->info = -3; ++ } else if (V->maxiter <= 0) { ++ V->info = -4; ++ } else if ((V->which != 0) && ++ (V->which != 1) && ++ (V->which != 6) && ++ (V->which != 7) && ++ (V->which != 8)) { ++ V->info = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ V->info = -6; ++ } else if ((V->mode < 1) || (V->mode > 5)) { ++ V->info = -10; ++ } else if ((V->mode == 1) && (V->bmat == 1)) { ++ V->info = -11; ++ } else if ((V->shift != 0) && (V->shift != 1)) { ++ V->info = -12; ++ } else if ((V->nev == 1) && (V->which == which_BE)) { ++ V->info = -13; ++ } ++ ++ if (V->info < 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ if (V->tol <= 0.0) { V->tol = ulp; } ++ ++ // NP is the number of additional steps to ++ // extend the length NEV Lanczos factorization. ++ V->np = V->ncv - V->nev; ++ ++ // Zero out internal workspace ++ for (j = 0; j < (V->ncv)*((V->ncv) + 8); j++) { workl[j] = 0.0; } ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:2*ncv) := generated tridiagonal matrix ++ // workl(2*ncv+1:2*ncv+ncv) := ritz values ++ // workl(3*ncv+1:3*ncv+ncv) := computed error bounds ++ // workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q ++ // workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace ++ ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ih = 0; ++ ritz = ih + 2*ldh; ++ bounds = ritz + V->ncv; ++ iq = bounds + V->ncv; ++ iw = iq + (V->ncv)*(V->ncv); ++ next = iw + 3*(V->ncv); ++ ++ ipntr[3] = next; ++ ipntr[4] = ih; ++ ipntr[5] = ritz; ++ ipntr[6] = bounds; ++ ipntr[10] = iw; ++ ++ // Carry out the Implicitly restarted Lanczos Iteration. ++ dsaup2(V, resid, v, ldv, &workl[ih], ldh, &workl[ritz], &workl[bounds], ++ &workl[iq], ldq, &workl[iw], ipntr, workd); ++ ++ /*-------------------------------------------------* ++ | ido .ne. 99 implies use of reverse communication | ++ | to compute operations involving OP or shifts. | ++ *-------------------------------------------------*/ ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info < 0) { return; } ++ if (V->info == 2) { V->info = 3; } ++ ++ return; ++} ++ ++ ++void ++dsaup2(struct ARPACK_arnoldi_update_vars_d *V, double* resid, double* v, int ldv, ++ double* h, int ldh, double* ritz, double* bounds, ++ double* q, int ldq, double* workl, int* ipntr, double* workd) ++{ ++ int int1 = 1, j, tmp_int, nevd2, nevm2; ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ double temp = 0.0; ++ // Initialize to silence the compiler warning ++ enum ARPACK_which temp_which = which_LM; ++ ++ if (V->ido == ido_FIRST) ++ { ++ // nev0 and np0 are integer variables hold the initial values of NEV & NP ++ V->aup2_nev0 = V->nev; ++ V->aup2_np0 = V->np; ++ ++ // kplusp is the bound on the largest Lanczos factorization built. ++ // nconv is the current number of "converged" eigenvalues. ++ // iter is the counter on the current iteration step. ++ V->aup2_kplusp = V->nev + V->np; ++ V->nconv = 0; ++ V->aup2_iter = 0; ++ ++ // Set flags for computing the first NEV steps of the Lanczos factorization. | ++ ++ V->aup2_getv0 = 1; ++ V->aup2_update = 0; ++ V->aup2_cnorm = 0; ++ V->aup2_ushift = 0; ++ ++ if (V->info != 0) ++ { ++ // User provides the initial residual vector. ++ V->aup2_initv = 1; ++ V->info = 0; ++ } else { ++ V->aup2_initv = 0; ++ } ++ } ++ ++ // Get a possibly random starting vector and ++ // force it into the range of the operator OP. ++ ++ if (V->aup2_getv0) ++ { ++ V->getv0_itry = 1; ++ dgetv0(V, V->aup2_initv, V->n, 0, v, ldv, resid, &V->aup2_rnorm, ipntr, workd); ++ if (V->ido != ido_DONE) { return; } ++ if (V->aup2_rnorm == 0.0) ++ { ++ V->info = -9; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_getv0 = 0; ++ V->ido = ido_FIRST; ++ } ++ ++ // Back from reverse communication : ++ // continue with update step ++ ++ if (V->aup2_update) { goto LINE20; } ++ ++ // Back from computing user specified shifts ++ ++ if (V->aup2_ushift) { goto LINE50; } ++ ++ // Back from computing residual norm ++ // at the end of the current iteration ++ ++ if (V->aup2_cnorm) { goto LINE100; } ++ ++ // Compute the first NEV steps of the Arnoldi factorization ++ ++ dsaitr(V, 0, V->aup2_nev0, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // ++ // M A I N ARNOLDI I T E R A T I O N L O O P ++ // Each iteration implicitly restarts the Arnoldi ++ // factorization in place. ++ // ++ ++LINE1000: ++ ++ V->aup2_iter += 1; ++ ++ // Compute NP additional steps of the Lanczos factorization. ++ ++ V->ido = ido_FIRST; ++ ++LINE20: ++ V->aup2_update = 1; ++ ++ dsaitr(V, V->nev, V->np, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ /*--------------------------------------------------* ++ | ido .ne. 99 implies use of reverse communication | ++ | to compute operations involving OP and possibly B | ++ *--------------------------------------------------*/ ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->aup2_update = 0; ++ ++ // Compute the eigenvalues and corresponding error bounds ++ // of the current symmetric tridiagonal matrix. ++ dseigt(V->aup2_rnorm, V->aup2_kplusp, h, ldh, ritz, bounds, workl, &V->info); ++ ++ if (V->info != 0) ++ { ++ V->info = -8; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Make a copy of eigenvalues and corresponding error ++ // bounds obtained from _seigt. ++ ++ dcopy_(&V->aup2_kplusp, ritz, &int1, &workl[V->aup2_kplusp], &int1); ++ dcopy_(&V->aup2_kplusp, bounds, &int1, &workl[2*V->aup2_kplusp], &int1); ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The selection is based on the requested number of ++ // eigenvalues instead of the current NEV and NP to ++ // prevent possible misconvergence. ++ // * Wanted Ritz values := RITZ(NP+1:NEV+NP) ++ // * Shifts := RITZ(1:NP) := WORKL(1:NP) ++ ++ V->nev = V->aup2_nev0; ++ V->np = V->aup2_np0; ++ ++ dsgets(V, &V->nev, &V->np, ritz, bounds, workl); ++ ++ // Convergence test ++ ++ dcopy_(&V->nev, &bounds[V->np], &int1, &workl[V->np], &int1); ++ dsconv(V->nev, &ritz[V->np], &workl[V->np], V->tol, &V->nconv); ++ ++ // Count the number of unwanted Ritz values that have zero ++ // Ritz estimates. If any Ritz estimates are equal to zero ++ // then a leading block of H of order equal to at least ++ // the number of Ritz values with zero Ritz estimates has ++ // split off. None of these Ritz values may be removed by ++ // shifting. Decrease NP the number of shifts to apply. If ++ // no shifts may be applied, then prepare to exit ++ ++ tmp_int = V->np; ++ for (j = 0; j < tmp_int; j++) ++ { ++ if (bounds[j] == 0.0) ++ { ++ V->np -= 1; ++ V->nev += 1; ++ } ++ } ++ // 30 ++ ++ if ((V->nconv >= V->aup2_nev0) || (V->aup2_iter > V->maxiter) || (V->np == 0)) ++ { ++ // Prepare to exit. Put the converged Ritz values ++ // and corresponding bounds in RITZ(1:NCONV) and ++ // BOUNDS(1:NCONV) respectively. Then sort. Be ++ // careful when NCONV > NP since we don't want to ++ // swap overlapping locations. ++ ++ if (V->which == which_BE) ++ { ++ ++ // Both ends of the spectrum are requested. ++ // Sort the eigenvalues into algebraically decreasing ++ // order first then swap low end of the spectrum next ++ // to high end in appropriate locations. ++ // NOTE: when np < floor(nev/2) be careful not to swap ++ // overlapping locations. ++ ++ dsortr(which_SA, 1, V->aup2_kplusp, ritz, bounds); ++ nevd2 = V->aup2_nev0 / 2; ++ nevm2 = V->aup2_nev0 - nevd2; ++ if (V->nev > 1) ++ { ++ V->np = V->aup2_kplusp - V->aup2_nev0; ++ ++ tmp_int = (nevd2 < V->np ? nevd2 : V->np); ++ int tmp_int2 = V->aup2_kplusp - tmp_int; ++ ++ dswap_(&tmp_int, &ritz[nevm2], &int1, &ritz[tmp_int2], &int1); ++ dswap_(&tmp_int, &bounds[nevm2], &int1, &bounds[tmp_int2], &int1); ++ } ++ ++ } else { ++ ++ // LM, SM, LA, SA case. ++ // Sort the eigenvalues of H into the an order that ++ // is opposite to WHICH, and apply the resulting ++ // order to BOUNDS. The eigenvalues are sorted so ++ // that the wanted part are always within the first ++ // NEV locations. ++ ++ if (V->which == which_LM) { temp_which = which_SM; } ++ if (V->which == which_SM) { temp_which = which_LM; } ++ if (V->which == which_LA) { temp_which = which_SA; } ++ if (V->which == which_SA) { temp_which = which_LA; } ++ ++ dsortr(temp_which, 1, V->aup2_kplusp, ritz, bounds); ++ } ++ ++ // Scale the Ritz estimate of each Ritz value ++ // by 1 / max(eps23,magnitude of the Ritz value). ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmax(eps23, fabs(ritz[j])); ++ bounds[j] = bounds[j] / temp; ++ } ++ // 35 ++ ++ // Sort the Ritz values according to the scaled Ritz ++ // estimates. This will push all the converged ones ++ // towards the front of ritzr, ritzi, bounds ++ // (in the case when NCONV < NEV.) ++ ++ dsortr(which_LA, 1, V->aup2_nev0, bounds, ritz); ++ ++ // Scale the Ritz estimate back to its original ++ // value. ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmax(eps23, fabs(ritz[j])); ++ bounds[j] = bounds[j] * temp; ++ } ++ // 40 ++ ++ // Sort the "converged" Ritz values again so that ++ // the "threshold" values and their associated Ritz ++ // estimates appear at the appropriate position in ++ // ritz and bound. ++ ++ if (V->which == which_BE) ++ { ++ ++ // Sort the "converged" Ritz values in increasing ++ // order. The "threshold" values are in the ++ // middle. ++ ++ dsortr(which_LA, 1, V->nconv, ritz, bounds); ++ } else { ++ ++ // In LM, SM, LA, SA case, sort the "converged" ++ // Ritz values according to WHICH so that the ++ // "threshold" value appears at the front of ++ // ritz. ++ ++ dsortr(V->which, 1, V->nconv, ritz, bounds); ++ } ++ ++ // Use h( 1,1 ) as storage to communicate ++ // rnorm to _seupd if needed ++ ++ h[0] = V->aup2_rnorm; ++ ++ // Max iterations have been exceeded. ++ ++ if ((V->aup2_iter > V->maxiter) && (V->nconv < V->nev)) ++ { ++ V->info = 1; ++ } ++ ++ // No shifts to apply. ++ ++ if ((V->np == 0) && (V->nconv < V->aup2_nev0)) ++ { ++ V->info = 2; ++ } ++ ++ V->np = V->nconv; ++ V->nev = V->nconv; ++ V->iter = V->aup2_iter; ++ V->ido = ido_DONE; ++ return; ++ ++ } else if ((V->nconv < V->nev) && (V->shift == 1)) { ++ ++ // Do not have all the requested eigenvalues yet. ++ // To prevent possible stagnation, adjust the number ++ // of Ritz values and the shifts. ++ ++ int nevbef = V->nev; ++ V->nev += (V->nconv > (V->np / 2) ? (V->np / 2) : V->nconv); ++ if ((V->nev == 1) && (V->aup2_kplusp >= 6)) ++ { ++ V->nev = V->aup2_kplusp / 2; ++ } else if ((V->nev == 1) && (V->aup2_kplusp > 2)) ++ { ++ V->nev = 2; ++ } ++ V->np = V->aup2_kplusp - V->nev; ++ ++ // If the size of NEV was just increased resort the eigenvalues. ++ ++ if (nevbef < V->nev) ++ { ++ dsgets(V, &V->nev, &V->np, ritz, bounds, workl); ++ } ++ } ++ ++ if (V->shift == 0) ++ { ++ // User specified shifts: reverse communication to ++ // compute the shifts. They are returned in the first ++ // NP locations of WORKL. ++ ++ V->aup2_ushift = 1; ++ V->ido = ido_USER_SHIFT; ++ return; ++ } ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // User specified shifts are returned ++ // in WORKL(1:*NP) ++ ++ V->aup2_ushift = 0; ++ ++ // Move the NP shifts to the first NP locations of RITZ to ++ // free up WORKL. This is for the non-exact shift case; ++ // in the exact shift case, dsgets already handles this. ++ ++ if (V->shift == 0) { dcopy_(&V->np, workl, &int1, ritz, &int1); } ++ ++ /*--------------------------------------------------------* ++ | Apply the NP0 implicit shifts by QR bulge chasing. | ++ | Each shift is applied to the entire tridiagonal matrix. | ++ | The first 2*N locations of WORKD are used as workspace. | ++ | After dsapps is done, we have a Lanczos | ++ | factorization of length NEV. | ++ *--------------------------------------------------------*/ ++ ++ dsapps(V->n, &V->nev, V->np, ritz, v, ldv, h, ldh, resid, q, ldq, workd); ++ ++ // Compute the B-norm of the updated residual. ++ // Keep B*RESID in WORKD(1:N) to be used in ++ // the first step of the next call to dsaitr. ++ ++ V->aup2_cnorm = 1; ++ ++ if (V->bmat) ++ { ++ dcopy_(&V->n, resid, &int1, &workd[V->n], &int1); ++ ipntr[0] = V->n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*RESID ++ ++ return; ++ } else { ++ dcopy_(&V->n, resid, &int1, workd, &int1); ++ } ++ ++LINE100: ++ ++ /*---------------------------------* ++ | Back from reverse communication; | ++ | WORKD(1:N) := B*RESID | ++ *---------------------------------*/ ++ ++ if (V->bmat) ++ { ++ V->aup2_rnorm = sqrt(fabs(ddot_(&V->n, resid, &int1, workd, &int1))); ++ } else { ++ V->aup2_rnorm = dnrm2_(&V->n, resid, &int1); ++ } ++ ++ V->aup2_cnorm = 0; ++ ++ goto LINE1000; ++ ++ // ++ // E N D O F M A I N I T E R A T I O N L O O P ++ // ++ ++} ++ ++ ++void ++dsconv(int n, double *ritz, double *bounds, double tol, int* nconv) ++{ ++ const double eps23 = pow(ulp, 2.0 / 3.0); ++ double temp = 0.0; ++ ++ *nconv = 0; ++ // Convergence test ++ for (int i = 0; i < n; i++) ++ { ++ temp = fmax(eps23, fabs(ritz[i])); ++ if (fabs(bounds[i]) <= tol * temp) { *nconv += 1; } ++ } ++ ++ return; ++} ++ ++ ++void ++dseigt(double rnorm, int n, double* h, int ldh, double* eig, double* bounds, ++ double* workl, int* ierr) ++{ ++ int int1 = 1, tmp_int; ++ dcopy_(&n, &h[ldh], &int1, eig, &int1); ++ tmp_int = n - 1; ++ dcopy_(&tmp_int, &h[1], &int1, workl, &int1); ++ dstqrb(n, eig, workl, bounds, &workl[n], ierr); ++ if (*ierr != 0) { return; } ++ for (int k = 0; k < n; k++) { bounds[k] = rnorm * fabs(bounds[k]); } ++ return; ++} ++ ++ ++void ++dsaitr(struct ARPACK_arnoldi_update_vars_d *V, int k, int np, double* resid, double* rnorm, ++ double* v, int ldv, double* h, int ldh, int* ipntr, double* workd) ++{ ++ int i, infol, ipj, irj, ivj, jj, n, tmp_int; ++ const double sq2o2 = sqrt(2.0) / 2.0; ++ ++ int int1 = 1; ++ double dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0, temp1; ++ ++ n = V->n; // n is constant, this is just for typing convenience ++ ipj = 0; ++ irj = ipj + n; ++ ivj = irj + n; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // Initial call to this routine ++ ++ V->aitr_j = k; ++ V->info = 0; ++ V->aitr_step3 = 0; ++ V->aitr_step4 = 0; ++ V->aitr_orth1 = 0; ++ V->aitr_orth2 = 0; ++ V->aitr_restart = 0; ++ } ++ ++ // When in reverse communication mode one of: ++ // STEP3, STEP4, ORTH1, ORTH2, RSTART ++ // will be .true. when .... ++ // STEP3: return from computing OP*v_{j}. ++ // STEP4: return from computing B-norm of OP*v_{j} ++ // ORTH1: return from computing B-norm of r_{j+1} ++ // ORTH2: return from computing B-norm of ++ // correction to the residual vector. ++ // RSTART: return from OP computations needed by ++ // dgetv0. ++ ++ if (V->aitr_step3) { goto LINE50; } ++ if (V->aitr_step4) { goto LINE60; } ++ if (V->aitr_orth1) { goto LINE70; } ++ if (V->aitr_orth2) { goto LINE90; } ++ if (V->aitr_restart) { goto LINE30; } ++ ++ // Else this is the first step ++ ++ // ++ // A R N O L D I I T E R A T I O N L O O P ++ // ++ // Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) ++ ++LINE1000: ++ ++ // Check for exact zero. Equivalent to determining whether ++ // a j-step Arnoldi factorization is present. ++ ++ if (*rnorm > 0.0) { goto LINE40; } ++ ++ // Invariant subspace found, generate a new starting ++ // vector which is orthogonal to the current Arnoldi ++ // basis and continue the iteration. ++ ++ V->getv0_itry = 1; ++ ++LINE20: ++ V->aitr_restart = 1; ++ V->ido = ido_FIRST; ++ ++LINE30: ++ ++ // If in reverse communication mode and aitr_restart = 1, flow returns here. ++ ++ dgetv0(V, 0, n, V->aitr_j, v, ldv, resid, rnorm, ipntr, workd); ++ ++ if (V->ido != ido_DONE) { return; } ++ V->aitr_ierr = V->info; ++ if (V->aitr_ierr < 0) ++ { ++ V->getv0_itry += 1; ++ if (V->getv0_itry <= 3) { goto LINE20; } ++ ++ // Give up after several restart attempts. ++ // Set INFO to the size of the invariant subspace ++ // which spans OP and exit. ++ ++ V->info = V->aitr_j; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++LINE40: ++ ++ // STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm ++ // Note that p_{j} = B*r_{j-1}. In order to avoid overflow ++ // when reciprocating a small RNORM, test against lower ++ // machine bound. ++ ++ dcopy_(&n, resid, &int1, &v[ldv*(V->aitr_j)], &int1); ++ if (*rnorm >= unfl) ++ { ++ temp1 = 1.0 / *rnorm; ++ dscal_(&n, &temp1, &v[ldv*(V->aitr_j)], &int1); ++ dscal_(&n, &temp1, &workd[ipj], &int1); ++ } else { ++ dlascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &v[ldv*(V->aitr_j)], &n, &infol); ++ dlascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &workd[ipj], &n, &infol); ++ } ++ ++ // STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} ++ // Note that this is not quite yet r_{j}. See STEP 4 ++ ++ V->aitr_step3 = 1; ++ dcopy_(&n, &v[ldv*(V->aitr_j)], &int1, &workd[ivj], &int1); ++ ipntr[0] = ivj; ++ ipntr[1] = irj; ++ ipntr[2] = ipj; ++ V->ido = ido_OPX; ++ ++ // Exit in order to compute OP*v_{j} ++ ++ return; ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // WORKD(IRJ:IRJ+N-1) := OP*v_{j} ++ ++ V->aitr_step3 = 0; ++ ++ // Put another copy of OP*v_{j} into RESID. ++ ++ dcopy_(&n, &workd[irj], &int1, resid, &int1); ++ ++ // STEP 4: Finish extending the symmetric ++ // Arnoldi to length j. If MODE = 2 ++ // then B*OP = B*inv(B)*A = A and ++ // we don't need to compute B*OP. ++ // NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is ++ // assumed to have A*v_{j}. ++ ++ if (V->mode == 2) { goto LINE65; } ++ if (V->bmat) ++ { ++ V->aitr_step4 = 1; ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*OP*v_{j} ++ ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE60: ++ ++ // Back from reverse communication; ++ // WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. ++ ++ V->aitr_step4 = 0; ++ ++ // The following is needed for STEP 5. ++ // Compute the B-norm of OP*v_{j}. ++ ++LINE65: ++ ++ if (V->mode == 2) ++ { ++ ++ // Note that the B-norm of OP*v_{j} ++ // is the inv(B)-norm of A*v_{j}. ++ ++ V->aitr_wnorm = ddot_(&n, resid, &int1, &workd[ivj], &int1); ++ V->aitr_wnorm = sqrt(fabs(V->aitr_wnorm)); ++ } else if (V->bmat) { ++ V->aitr_wnorm = ddot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_wnorm = sqrt(fabs(V->aitr_wnorm)); ++ } else { ++ V->aitr_wnorm = dnrm2_(&n, resid, &int1); ++ } ++ ++ // Compute the j-th residual corresponding ++ // to the j step factorization. ++ // Use Classical Gram Schmidt and compute: ++ // w_{j} <- V_{j}^T * B * OP * v_{j} ++ // r_{j} <- OP*v_{j} - V_{j} * w_{j} ++ ++ // Compute the j Fourier coefficients w_{j} ++ // WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. ++ tmp_int = V->aitr_j + 1; ++ if (V->mode != 2) ++ { ++ dgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &workd[irj], &int1); ++ } else { ++ dgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ivj], &int1, &dbl0, &workd[irj], &int1); ++ } ++ ++ // Orthogonalize r_{j} against V_{j}. ++ // RESID contains OP*v_{j}. See STEP 3. ++ ++ dgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &workd[irj], &int1, &dbl1, resid, &int1); ++ ++ // Extend H to have j rows and columns. ++ ++ h[V->aitr_j + ldh] = workd[irj + V->aitr_j]; ++ ++ if ((V->aitr_j == 0) || (V->aitr_restart)) ++ { ++ h[V->aitr_j] = 0.0; ++ } else { ++ h[V->aitr_j] = *rnorm; ++ } ++ ++ V->aitr_orth1 = 1; ++ V->aitr_iter = 0; ++ ++ if (V->bmat) ++ { ++ dcopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j} ++ ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE70: ++ ++ // Back from reverse communication if ORTH1 = .true. ++ // WORKD(IPJ:IPJ+N-1) := B*r_{j}. ++ ++ V->aitr_orth1 = 0; ++ ++ // Compute the B-norm of r_{j}. ++ ++ if (V->bmat) ++ { ++ *rnorm = ddot_(&n, resid, &int1, &workd[ipj], &int1); ++ *rnorm = sqrt(fabs(*rnorm)); ++ } else { ++ *rnorm = dnrm2_(&n, resid, &int1); ++ } ++ ++ // STEP 5: Re-orthogonalization / Iterative refinement phase ++ // Maximum NITER_ITREF tries. ++ // ++ // s = V_{j}^T * B * r_{j} ++ // r_{j} = r_{j} - V_{j}*s ++ // alphaj = alphaj + s_{j} ++ // ++ // The stopping criteria used for iterative refinement is ++ // discussed in Parlett's book SEP, page 107 and in Gragg & ++ // Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. ++ // Determine if we need to correct the residual. The goal is ++ // to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || ++ ++ if (*rnorm > sq2o2*V->aitr_wnorm) { goto LINE100; } ++ ++ // Enter the Iterative refinement phase. If further ++ // refinement is necessary, loop back here. The loop ++ // variable is ITER. Perform a step of Classical ++ // Gram-Schmidt using all the Arnoldi vectors V_{j} ++ ++LINE80: ++ ++ // Compute V_{j}^T * B * r_{j}. ++ // WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). ++ tmp_int = V->aitr_j + 1; ++ dgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &workd[irj], &int1); ++ ++ // Compute the correction to the residual: ++ // r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). ++ // The correction to H is v(:,1:J)*H(1:J,1:J) ++ // + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. ++ ++ dgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &workd[irj], &int1, &dbl1, resid, &int1); ++ ++ if ((V->aitr_j == 0) || (V->aitr_restart)) ++ { ++ h[V->aitr_j] = 0.0; ++ } ++ h[V->aitr_j + ldh] += workd[irj + V->aitr_j]; ++ ++ V->aitr_orth2 = 1; ++ ++ if (V->bmat) ++ { ++ dcopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j}. ++ // r_{j} is the corrected residual. ++ ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE90: ++ ++ // Back from reverse communication if ORTH2 = .true. ++ ++ // Compute the B-norm of the corrected residual r_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_rnorm1 = ddot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_rnorm1 = sqrt(fabs(V->aitr_rnorm1)); ++ } else { ++ V->aitr_rnorm1 = dnrm2_(&n, resid, &int1); ++ } ++ ++ // Determine if we need to perform another ++ // step of re-orthogonalization. ++ ++ if (V->aitr_rnorm1 > sq2o2*(*rnorm)) ++ { ++ ++ // No need for further refinement. ++ ++ *rnorm = V->aitr_rnorm1; ++ ++ } else { ++ ++ // Another step of iterative refinement step is required. ++ ++ *rnorm = V->aitr_rnorm1; ++ V->aitr_iter += 1; ++ if (V->aitr_iter < 2) { goto LINE80; } ++ ++ // Otherwise RESID is numerically in the span of V ++ ++ for (jj = 0; jj < n; jj++) ++ { ++ resid[jj] = 0.0; ++ } ++ *rnorm = 0.0; ++ } ++ ++ // Branch here directly if iterative refinement ++ // wasn't necessary or after at most NITER_REF ++ // steps of iterative refinement. ++ ++LINE100: ++ ++ V->aitr_restart = 0; ++ V->aitr_orth2 = 0; ++ ++ // Make sure the last off-diagonal element is non negative ++ // If not perform a similarity transformation on H(1:j,1:j) ++ // and scale v(:,j) by -1. ++ ++ if (h[V->aitr_j] < 0.0) ++ { ++ h[V->aitr_j] = -h[V->aitr_j]; ++ if (V->aitr_j < k + np - 1) ++ { ++ dscal_(&n, &dblm1, &v[V->aitr_j + 1], &int1); ++ } else { ++ dscal_(&n, &dblm1, resid, &int1); ++ } ++ } ++ ++ // STEP 6: Update j = j+1; Continue ++ ++ V->aitr_j += 1; ++ if (V->aitr_j >= k + np) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Loop back to extend the factorization by another step. ++ ++ goto LINE1000; ++ ++} ++ ++ ++void ++dsapps(int n, int* kev, int np, double* shift, double* v, int ldv, double* h, int ldh, ++ double* resid, double* q, int ldq, double* workd) ++{ ++ int i, iend, istart, jj, kplusp, tmp_int, int1 = 1; ++ double a1, a2, a3, a4, c, f, g, r, s, sigma, tst1; ++ double dbl0 = 0.0, dbl1 = 1.0, dblm1 = -1.0; ++ ++ iend = 0; ++ kplusp = *kev + np; ++ ++ // Initialize Q to the identity to accumulate ++ // the rotations and reflections ++ ++ dlaset_("A", &kplusp, &kplusp, &dbl0, &dbl1, q, &ldq); ++ ++ // Quick return if there are no shifts to apply ++ ++ if (np == 0) { return; } ++ ++ for (jj = 0; jj < np; jj++) ++ { ++ sigma = shift[jj]; ++ ++ // Check for splitting and deflation. Currently we consider ++ // an off-diagonal element h(i+1,1) negligible if ++ // h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) ++ // for i=1:KEV+NP-1. ++ // If above condition tests true then we set h(i+1,1) = 0. ++ // Note that h(1:KEV+NP,1) are assumed to be non negative. ++ ++ istart = 0; ++ while (istart < kplusp - 1) ++ { ++ ++ for (iend = istart; iend < kplusp - 1; iend++) ++ { ++ tst1 = fabs(h[iend + ldh]) + fabs(h[iend + 1 + ldh]); ++ if (h[iend + 1] <= ulp * tst1) ++ { ++ h[iend + 1] = 0.0; ++ break; ++ } ++ } ++ ++ // Scalar block, skipping, correct the sign if necessary ++ if (istart == iend) ++ { ++ istart += 1; ++ if (h[iend] < 0.0) ++ { ++ h[iend] = -h[iend]; ++ dscal_(&kplusp, &dblm1, &q[ldq*(iend)], &int1); ++ } ++ continue; ++ } ++ ++ // We have a valid block [istart, iend] inclusive ++ f = h[istart + ldh] - sigma; ++ g = h[istart + 1]; ++ ++ for (i = istart; i < iend; i++) ++ { ++ // Applying the plane rotations that create and chase the bulge X ++ // ++ // [c, s] [ x x ] [c, -s] [ x x X ] ++ // [-s, c] [ x x x ] [s, c] [ x x x ] ++ // [ x x x ] => [ X x x x ] ++ // [ x x x ] [ x x x ] ++ // [ ...] [ ...] ++ // ++ // dlartgp (instead of dlartg) is used to make sure that the ++ // off-diagonal elements stay non-negative, (cf. F77 code for ++ // manual handling). ++ ++ // a1 a2 ++ // [c, s] [ k m ] [c, -s] [ c*k + s*m, s*k + c*m] [c, -s] ++ // [-s, c] [ m n ] [s, c] [-s*k + c*m, -s*m + c*n] [s, c] ++ // a3 a4 ++ ++ dlartgp_(&f, &g, &c, &s, &r); ++ if (i > istart) ++ { ++ h[i] = r; ++ } ++ a1 = c*h[i + ldh] + s*h[i + 1]; ++ a2 = c*h[i + 1] + s*h[i + 1 + ldh]; ++ a4 = c*h[i + 1 + ldh] - s*h[i + 1]; ++ a3 = c*h[i + 1] - s*h[i + ldh]; ++ h[i + ldh] = c*a1 + s*a2; // h[i , i ] ++ h[i + 1 + ldh] = c*a4 - s*a3; // h[i+1, i+1] ++ h[i + 1] = c*a3 + s*a4; // h[i+1, i ] ++ ++ // Accumulate the rotation also in Q ++ tmp_int = (i + jj + 2 > kplusp ? kplusp : i + jj + 2); ++ drot_(&tmp_int, &q[ldq*i], &int1, &q[ldq*(i+1)], &int1, &c, &s); ++ ++ if (i < iend - 1) ++ { ++ // g is the bulge created by the rotation ++ f = h[i + 1]; ++ g = s*h[i + 2]; ++ h[i + 2] = c*h[i + 2]; ++ } ++ } ++ istart = iend + 1; ++ if (h[iend] < 0.0) ++ { ++ h[iend] = -h[iend]; ++ dscal_(&kplusp, &dblm1, &q[ldq*(iend)], &int1); ++ } ++ } ++ } ++ // 90 ++ ++ // All shifts have been applied. Check for ++ // more possible deflation that might occur ++ // after the last shift is applied. ++ ++ for (i = 0; i < kplusp - 1; i++) ++ { ++ tst1 = fabs(h[i + ldh]) + fabs(h[i+1 + ldh]); ++ if (h[i+1] <= ulp*tst1) ++ { ++ h[i+1] = 0.0; ++ } ++ } ++ // 100 ++ ++ // Compute the (kev+1)-st column of (V*Q) and ++ // temporarily store the result in WORKD(N+1:2*N). ++ // This is not necessary if h(kev+1,1) = 0. ++ ++ if (h[*kev] > 0.0) ++ { ++ dgemv_("N", &n, &kplusp, &dbl1, v, &ldv, &q[ldq*(*kev)], &int1, &dbl0, &workd[n], &int1); ++ } ++ ++ // Compute column 1 to kev of (V*Q) in backward order ++ // taking advantage that Q is an upper triangular matrix ++ // with lower bandwidth np. ++ // Place results in v(:,kplusp-kev:kplusp) temporarily. ++ ++ for (i = 0; i < *kev; i++) ++ { ++ tmp_int = kplusp - i; ++ dgemv_("N", &n, &tmp_int, &dbl1, v, &ldv, &q[ldq*(*kev-i-1)], &int1, &dbl0, workd, &int1); ++ dcopy_(&n, workd, &int1, &v[ldv*(kplusp-i-1)], &int1); ++ } ++ // 130 ++ ++ // Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). ++ ++ for (i = 0; i < *kev; i++) ++ { ++ dcopy_(&n, &v[ldv*(np+i)], &int1, &v[ldv*i], &int1); ++ } ++ // 140 ++ ++ if (h[*kev] > 0.0) ++ { ++ dcopy_(&n, &workd[n], &int1, &v[ldv*(*kev)], &int1); ++ } ++ ++ // Update the residual vector: ++ // r <- sigmak*r + betak*v(:,kev+1) ++ // where ++ // sigmak = (e_{kev+p}'*Q)*e_{kev} ++ // betak = e_{kev+1}'*H*e_{kev} ++ ++ dscal_(&n, &q[kplusp-1 + (*kev-1)*ldq], resid, &int1); ++ if (h[*kev] > 0.0) ++ { ++ daxpy_(&n, &h[*kev], &v[ldv*(*kev)], &int1, resid, &int1); ++ } ++ ++ return; ++} ++ ++ ++void ++dsgets(struct ARPACK_arnoldi_update_vars_d *V, int* kev, int* np, double* ritz, ++ double* bounds, double* shifts) ++{ ++ int kevd2, tmp1, tmp2, int1 = 1; ++ if (V->which == which_BE) ++ { ++ // Both ends of the spectrum are requested. ++ // Sort the eigenvalues into algebraically increasing ++ // order first then swap high end of the spectrum next ++ // to low end in appropriate locations. ++ // NOTE: when np < floor(kev/2) be careful not to swap ++ // overlapping locations. ++ ++ dsortr(which_LA, 1, *kev + *np, ritz, bounds); ++ kevd2 = *kev / 2; ++ if (*kev > 1) ++ { ++ tmp1 = (kevd2 > *np ? *np : kevd2); ++ tmp2 = (kevd2 > *np ? kevd2 : *np); ++ dswap_(&tmp1, ritz, &int1, &ritz[tmp2], &int1); ++ dswap_(&tmp1, bounds, &int1, &bounds[tmp2], &int1); ++ } ++ } else { ++ ++ // LM, SM, LA, SA case. ++ // Sort the eigenvalues of H into the desired order ++ // and apply the resulting order to BOUNDS. ++ // The eigenvalues are sorted so that the wanted part ++ // are always in the last KEV locations. ++ ++ dsortr(V->which, 1, *kev + *np, ritz, bounds); ++ } ++ ++ if ((V->shift == 1) && (*np > 0)) ++ { ++ ++ // Sort the unwanted Ritz values used as shifts so that ++ // the ones with largest Ritz estimates are first. ++ // This will tend to minimize the effects of the ++ // forward instability of the iteration when the shifts ++ // are applied in subroutine dsapps. ++ ++ dsortr(which_SM, 1, *np, bounds, ritz); ++ dcopy_(np, ritz, &int1, shifts, &int1); ++ } ++} ++ ++ ++void ++dgetv0(struct ARPACK_arnoldi_update_vars_d *V, int initv, int n, int j, ++ double* v, int ldv, double* resid, double* rnorm, int* ipntr, double* workd) ++{ ++ int jj, int1 = 1; ++ const double sq2o2 = sqrt(2.0) / 2.0; ++ double dbl1 = 1.0, dbl0 = 0.0, dblm1 = -1.0; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->info = 0; ++ V->getv0_iter = 0; ++ V->getv0_first = 0; ++ V->getv0_orth = 0; ++ ++ // Possibly generate a random starting vector in RESID ++ // Skip if this the return of ido_RANDOM. ++ ++ if (!(initv)) ++ { ++ // Request a random vector from the user into resid ++ V->ido = ido_RANDOM; ++ return; ++ } else { ++ V->ido = ido_RANDOM; ++ } ++ } ++ ++ // Back from random vector generation ++ if (V->ido == ido_RANDOM) ++ { ++ // Force the starting vector into the range of OP to handle ++ // the generalized problem when B is possibly (singular). ++ ++ if (V->getv0_itry == 1) ++ { ++ ipntr[0] = 0; ++ ipntr[1] = n; ++ dcopy_(&n, resid, &int1, workd, &int1); ++ V->ido = ido_RANDOM_OPX; ++ return; ++ } else if ((V->getv0_itry > 1) && (V->bmat == 1)) ++ { ++ dcopy_(&n, resid, &int1, &workd[n], &int1); ++ } ++ } ++ ++ // Back from computing OP*(initial-vector) ++ ++ if (V->getv0_first) { goto LINE20; } ++ ++ // Back from computing OP*(orthogonalized-vector) ++ ++ if (V->getv0_orth) { goto LINE40; } ++ ++ // Starting vector is now in the range of OP; r = OP*r; ++ // Compute B-norm of starting vector. ++ ++ V->getv0_first = 1; ++ if (V->getv0_itry == 1) ++ { ++ dcopy_(&n, &workd[n], &int1, resid, &int1); ++ } ++ if (V->bmat) ++ { ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE20: ++ ++ V->getv0_first = 0; ++ if (V->bmat) ++ { ++ V->getv0_rnorm0 = ddot_(&n, resid, &int1, workd, &int1); ++ V->getv0_rnorm0 = sqrt(fabs(V->getv0_rnorm0)); ++ } else { ++ V->getv0_rnorm0 = dnrm2_(&n, resid, &int1); ++ } ++ *rnorm = V->getv0_rnorm0; ++ ++ // Exit if this is the very first Arnoldi step ++ ++ if (j == 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Otherwise need to B-orthogonalize the starting vector against ++ // the current Arnoldi basis using Gram-Schmidt with iter. ref. ++ // This is the case where an invariant subspace is encountered ++ // in the middle of the Arnoldi factorization. ++ // ++ // s = V^{T}*B*r; r = r - V*s; ++ // ++ // Stopping criteria used for iter. ref. is discussed in ++ // Parlett's book, page 107 and in Gragg & Reichel TOMS paper. ++ ++ V->getv0_orth = 1; ++ ++LINE30: ++ ++ dgemv_("T", &n, &j, &dbl1, v, &ldv, workd, &int1, &dbl0, &workd[n], &int1); ++ dgemv_("N", &n, &j, &dblm1, v, &ldv, &workd[n], &int1, &dbl1, resid, &int1); ++ ++ // Compute the B-norm of the orthogonalized starting vector ++ ++ if (V->bmat) ++ { ++ dcopy_(&n, resid, &int1, &workd[n], &int1); ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ dcopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE40: ++ if (V->bmat) ++ { ++ *rnorm = ddot_(&n, resid, &int1, workd, &int1); ++ *rnorm = sqrt(fabs(*rnorm)); ++ } else { ++ *rnorm = dnrm2_(&n, resid, &int1); ++ } ++ ++ // Check for further orthogonalization. ++ ++ if (*rnorm > sq2o2*V->getv0_rnorm0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->getv0_iter += 1; ++ if (V->getv0_iter < 5) ++ { ++ ++ // Perform iterative refinement step ++ ++ V->getv0_rnorm0 = *rnorm; ++ goto LINE30; ++ } else { ++ ++ // Iterative refinement step "failed" ++ ++ for (jj = 0; jj < n; jj++) { resid[jj] = 0.0; } ++ *rnorm = 0.0; ++ V->info = -1; ++ } ++ ++ V->ido = ido_DONE; ++ ++ return; ++} ++ ++ ++void ++dsortr(const enum ARPACK_which w, const int apply, const int n, double* x1, double* x2) ++{ ++ int i, igap, j; ++ double temp; ++ ARPACK_compare_rfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortr_LM; ++ break; ++ case which_SM: ++ f = sortr_SM; ++ break; ++ case which_LA: ++ f = sortr_LA; ++ break; ++ case which_SA: ++ f = sortr_SA; ++ break; ++ default: ++ f = sortr_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(x1[j], x1[j+igap])) ++ { ++ if (j < 0) { break; } ++ temp = x1[j]; ++ x1[j] = x1[j+igap]; ++ x1[j+igap] = temp; ++ ++ if (apply) ++ { ++ temp = x2[j]; ++ x2[j] = x2[j+igap]; ++ x2[j+igap] = temp; ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++} ++ ++ ++void ++dsesrt(const enum ARPACK_which w, const int apply, const int n, double* x, int na, double* a, const int lda) ++{ ++ int i, igap, j, int1 = 1; ++ double temp; ++ ARPACK_compare_rfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortr_LM; ++ break; ++ case which_SM: ++ f = sortr_SM; ++ break; ++ case which_LA: ++ f = sortr_LA; ++ break; ++ case which_SA: ++ f = sortr_SA; ++ break; ++ default: ++ f = sortr_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(x[j], x[j + igap])) ++ { ++ if (j < 0) { break; } ++ temp = x[j]; ++ x[j] = x[j+igap]; ++ x[j+igap] = temp; ++ ++ if (apply) ++ { ++ dswap_(&na, &a[lda*j], &int1, &a[lda*(j+igap)], &int1); ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++ // 10, 40, 70, 120 ++} ++ ++ ++void ++dstqrb(int n, double* d, double* e, double* z, double* work, int* info) ++{ ++ int int1 = 1, int0 = 0; ++ double eps2 = pow(ulp, 2.0); ++ double safmin = unfl; ++ double safmax = (1.0 / safmin); ++ double ssfmax = sqrt(safmax) / 3.0; ++ double ssfmin = sqrt(safmin) / eps2; ++ ++ int nmaxit, jtot, i, ii, j, k, l1, m = 0, tmp_int = 0, l, lsv, lend, lendsv, iscale; ++ double anorm = 0.0, rt1 = 0.0, rt2 = 0.0, c = 0.0, s = 0.0, g = 0.0, r = 0.0, p = 0.0; ++ double b, f, tst; ++ ++ *info = 0; ++ if (n == 0) { return; } ++ if (n == 1) { z[0] = 1.0; return; } ++ ++ // Set z as the last row of identity matrix ++ for (i = 0; i < n-1; i++) { z[i] = 0.0; } ++ z[n-1] = 1.0; ++ ++ nmaxit = n*30; ++ jtot = 0; ++ ++ // Determine where the matrix splits and choose QL or QR iteration ++ // for each block, according to whether top or bottom diagonal ++ // element is smaller. ++ ++ // Translation Note: ++ // All indices are 1-based, since the F77 code is very complicated. ++ // Instead array indices are decremented where necessary. ++ ++ l1 = 1; ++ ++ while (jtot < nmaxit) ++ { ++ if (l1 > n) { break; } ++ ++ if (l1 > 1) { e[l1 - 2] = 0.0; } ++ if (l1 <= n - 1) ++ { ++ for (m = l1; m <= n - 1; m++) ++ { ++ tst = fabs(e[m - 1]); ++ if (tst == 0.0) { break; } ++ if (tst <= (sqrt(fabs(d[m-1]))*sqrt(fabs(d[m])))*ulp) ++ { ++ e[m-1] = 0.0; ++ break; ++ } ++ } ++ // 20 ++ } else { ++ m = n; ++ } ++ // 30 ++ ++ // m will mark the splitting point, if any. ++ l = l1; ++ lsv = l; ++ lend = m; ++ lendsv = lend; ++ l1 = m + 1; ++ ++ // Scalar block, skipping ++ if (lend == l) { continue; } ++ ++ // Scale submatrix in rows and columns L to LEND ++ tmp_int = lend - l + 1; ++ anorm = dlanst_("I", &tmp_int, &d[l-1], &e[l-1]); ++ iscale = 0; ++ ++ if (anorm == 0.0) { continue; } ++ ++ if (anorm > ssfmax) ++ { ++ iscale = 1; ++ dlascl_("G", &int0, &int0, &anorm, &ssfmax, &tmp_int, &int1, &d[l-1], &n, info); ++ tmp_int -= 1; ++ dlascl_("G", &int0, &int0, &anorm, &ssfmax, &tmp_int, &int1, &e[l-1], &n, info); ++ } else if (anorm < ssfmin) { ++ iscale = 2; ++ dlascl_("G", &int0, &int0, &anorm, &ssfmin, &tmp_int, &int1, &d[l-1], &n, info); ++ tmp_int -= 1; ++ dlascl_("G", &int0, &int0, &anorm, &ssfmin, &tmp_int, &int1, &e[l-1], &n, info); ++ } ++ // Choose between QL and QR iteration ++ ++ if (fabs(d[lend-1]) < fabs(d[l-1])) ++ { ++ lend = lsv; ++ l = lendsv; ++ } ++ if (lend > l) ++ { ++ // QL Iteration ++ while (1) ++ { ++ // Look for small subdiagonal element. ++ // 40 ++ if (l != lend) ++ { ++ for (m = l; m < lend; m++) ++ { ++ tst = fabs(e[m-1]); ++ tst = tst*tst; ++ if (tst <= (eps2*fabs(d[m - 1]))*fabs(d[m]) + safmin) { break; } ++ if (m == lend - 1) { m = lend; break; } // No break condition ++ } ++ // 50, 60 ++ } else { ++ m = lend; ++ } ++ if (m < lend) { e[m - 1] = 0.0; } ++ ++ p = d[l - 1]; ++ if (m == l) ++ { ++ // 80 ++ // Eigenvalue found ++ d[l - 1] = p; ++ l += 1; ++ if (l <= lend) { continue; } // Top of QL iteration ++ break; // go to 140 undo scaling ++ } ++ // If remaining matrix is 2x2, use dlaev2 to compute its eigensystem ++ if (m == l + 1) ++ { ++ dlaev2_(&d[l - 1], &e[l - 1], &d[l], &rt1, &rt2, &c, &s); ++ work[l - 1] = c; ++ work[n - 1 + l - 1] = s; ++ tst = z[l]; ++ z[l] = c*tst - s*z[l-1]; ++ z[l-1] = s*tst + c*z[l-1]; ++ d[l-1] = rt1; ++ d[l] = rt2; ++ e[l-1] = 0.0; ++ l += 2; ++ if (l <= lend) { continue; } // go to 40 ++ break; // go to 140 ++ } ++ ++ if (jtot == nmaxit) { break; } // go to 140 ++ jtot += 1; ++ ++ // Form shift ++ g = (d[l]- p) / (2.0 * e[l-1]); ++ r = hypot(g, 1.0); ++ g = d[m-1] - p + (e[l-1] / (g + copysign(r, g))); ++ ++ s = 1.0; ++ c = 1.0; ++ p = 0.0; ++ ++ // Inner loop ++ for (i = m - 1; i >= l; i--) ++ { ++ f = s * e[i-1]; ++ b = c * e[i-1]; ++ dlartg_(&g, &f, &c, &s, &r); ++ if (i != m - 1) { e[i] = r; } ++ g = d[i] - p; ++ r = (d[i-1] - g)*s + 2.0*c*b; ++ p = s*r; ++ d[i] = g + p; ++ g = c*r - b; ++ work[i-1] = c; ++ work[n-1+i-1] = -s; ++ } ++ // 70 ++ tmp_int = m - l + 1; ++ dlasr_("R", "V", "B", &int1, &tmp_int, &work[l-1], &work[n-1+l-1], &z[l-1], &int1); ++ ++ d[l-1] = d[l-1] - p; ++ e[l-1] = g; ++ ++ } ++ } else { ++ // QR Iteration ++ ++ // Look for small subdiagonal element. ++ while (1) ++ { ++ if (l != lend) ++ { ++ for (m = l; m > lend; m--) ++ { ++ tst = fabs(e[m-2]); ++ tst = tst*tst; ++ if (tst <= (eps2*fabs(d[m-1]))*fabs(d[m-2]) + safmin) { break; } ++ if (m == lend+1) { m = lend; break; } // No break ++ } ++ } else { ++ m = lend; ++ } ++ // 100, 110 ++ if (m > lend) { e[m-2] = 0.0; } ++ p = d[l-1]; ++ if (m == l) ++ { ++ // 130 ++ // Eigenvalue found ++ d[l-1] = p; ++ l -= 1; ++ if (l >= lend) { continue; } // Top of QR iteration ++ break; // go to 140 undo scaling ++ } ++ // If remaining matrix is 2x2, use dlaev2 to compute its eigensystem ++ if (m == l - 1) ++ { ++ dlaev2_(&d[l-2], &e[l-2], &d[l-1], &rt1, &rt2, &c, &s); ++ tst = z[l-1]; ++ z[l-1] = c*tst - s*z[l-2]; ++ z[l-2] = s*tst + c*z[l-2]; ++ d[l-2] = rt1; ++ d[l-1] = rt2; ++ e[l-2] = 0.0; ++ l -= 2; ++ ++ if (l >= lend) { continue; } // Top of QR iteration ++ break; // go to 140 undo scaling ++ } ++ ++ if (jtot == nmaxit) { break; } // go to 140 ++ jtot += 1; ++ ++ // Form the shift ++ g = (d[l-2] - p) / (2.0*e[l-2]); ++ r = hypot(g, 1.0); ++ g = d[m-1] - p + (e[l-2] / (g + copysign(r, g))); ++ ++ s = 1.0; ++ c = 1.0; ++ p = 0.0; ++ ++ // Inner loop ++ for (i = m; i < l; i++) ++ { ++ f = s * e[i-1]; ++ b = c * e[i-1]; ++ dlartg_(&g, &f, &c, &s, &r); ++ if (i != m) { e[i-2] = r; } ++ g = d[i-1] - p; ++ r = (d[i] - g)*s + 2.0*c*b; ++ p = s*r; ++ d[i-1] = g + p; ++ g = c*r - b; ++ ++ // Save rotations ++ work[i-1] = c; ++ work[n-1+i-1] = s; ++ } ++ // 120 ++ // Apply saved rotations. ++ tmp_int = l - m + 1; ++ dlasr_("R", "V", "F", &int1, &tmp_int, &work[m-1], &work[n-1+m-1], &z[m-1], &int1); ++ ++ d[l-1] = d[l-1] - p; ++ e[l - 2] = g; ++ ++ } ++ } ++ // 140 Still in the outer while loop; it breaks at the top ++ ++ // Undo scaling if necessary ++ tmp_int = lendsv-lsv+1; ++ if (iscale == 1) ++ { ++ ++ dlascl_("G", &int0, &int0, &ssfmax, &anorm, &tmp_int, &int1, &d[lsv-1], &n, info); ++ tmp_int -= 1; ++ dlascl_("G", &int0, &int0, &ssfmax, &anorm, &tmp_int, &int1, &e[lsv-1], &n, info); ++ ++ } else if (iscale == 2) { ++ ++ dlascl_("G", &int0, &int0, &ssfmin, &anorm, &tmp_int, &int1, &d[lsv-1], &n, info); ++ tmp_int -= 1; ++ dlascl_("G", &int0, &int0, &ssfmin, &anorm, &tmp_int, &int1, &e[lsv-1], &n, info); ++ ++ } ++ ++ // Check for no convergence to an eigenvalue after a total of n*maxit iterations ++ if (jtot >= nmaxit) ++ { ++ for (i = 0; i < n-1; i++) { if (e[i] != 0.0) { *info += 1; } } ++ return; // 150 ++ } ++ } ++ // Out of the while loop ++ ++ // Order eigenvalues and eigenvectors. ++ // Use selection sort to minimize swaps of eigenvectors. ++ for (ii = 1; ii < n; ii++) ++ { ++ i = ii - 1; ++ k = i; ++ p = d[i]; ++ ++ for (j = ii; j < n; j++) ++ { ++ if (d[j] < p) ++ { ++ k = j; ++ p = d[j]; ++ } ++ } ++ // 170 ++ if (k != i) ++ { ++ d[k] = d[i]; ++ d[i] = p; ++ p = z[k]; ++ z[k] = z[i]; ++ z[i] = p; ++ } ++ } ++ // 180 ++ ++ return; ++} ++ ++ ++int sortr_LM(const double x1, const double x2) { return (fabs(x1) > fabs(x2)); } ++int sortr_SM(const double x1, const double x2) { return (fabs(x1) < fabs(x2)); } ++int sortr_LA(const double x1, const double x2) { return (x1 > x2); } ++int sortr_SA(const double x1, const double x2) { return (x1 < x2); } +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.h +new file mode 100644 +index 0000000000..f0fb145cfb +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_double.h +@@ -0,0 +1,31 @@ ++#ifndef _ARPACK_S_DOUBLE_H ++#define _ARPACK_S_DOUBLE_H ++ ++#include "_arpack.h" ++ ++// BLAS Routines used ++void daxpy_(int* n, double* alpha, double* x, int* incx, double* y, int* incy); ++void dcopy_(int* n, double* x, int* incx, double* y, int* incy); ++double ddot_(int* n, double* x, int* incx, double* y, int* incy); ++void dgemv_(char* trans, int* m, int* n, double* alpha, double* a, int* lda, double* x, int* incx, double* beta, double* y, int* incy); ++void dger_(int* m, int* n, double* alpha, double* x, int* incx, double* y, int* incy, double* a, int* lda); ++double dnrm2_(int* n, double* x, int* incx); ++void drot_(int* n, double* sx, int* incx, double* sy, int* incy, double* c, double* s); ++void dscal_(int* n, double* alpha, double* x, int* incx); ++void dswap_(int* n, double* x, int* incx, double* y, int* incy); ++void dtrmm_(char* side, char* uplo, char* transa, char* diag, int* m, int* n, double* alpha, double* a, int* lda, double* b, int* ldb); ++ ++// LAPACK Routines used ++void dgeqr2_(int* m, int* n, double* a, int* lda, double* tau, double* work, int* info); ++void dlacpy_(char* uplo, int* m, int* n, double* a, int* lda, double* b, int* ldb); ++void dlaev2_(double* a, double* b, double* c, double* rt1, double* rt2, double* cs1, double* sn1); ++double dlanst_(char* norm, int* n, double* d, double* e); ++void dlartg_(double* f, double* g, double* c, double* s, double* r); ++void dlartgp_(double* f, double* g, double* c, double* s, double* r); ++void dlascl_(char* mtype, int* kl, int* ku, double* cfrom, double* cto, int* m, int* n, double* a, int* lda, int* info); ++void dlaset_(char* uplo, int* m, int* n, double* alpha, double* beta, double* a, int* lda); ++void dlasr_(char* side, char* pivot, char* direct, int* m, int* n, double* c, double* s, double* a, int* lda); ++void dorm2r_(char* side, char* trans, int* m, int* n, int* k, double* a, int* lda, double* tau, double* c, int* ldc, double* work, int* info); ++void dsteqr_(char* compz, int* n, double* d, double* e, double* z, int* ldz, double* work, int* info); ++ ++#endif +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.c b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.c +new file mode 100644 +index 0000000000..ac3d5471bf +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.c +@@ -0,0 +1,2238 @@ ++#include "_arpack_s_single.h" ++ ++typedef int ARPACK_compare_rfunc(const float, const float); ++ ++static int sortr_LM(const float, const float); ++static int sortr_SM(const float, const float); ++static int sortr_LA(const float, const float); ++static int sortr_SA(const float, const float); ++ ++static const float unfl = 1.1754943508222875e-38; ++static const float ulp = 1.1920928955078125e-07; ++ ++static void ssaup2(struct ARPACK_arnoldi_update_vars_s*, float*, float*, int, float*, int, float*, float*, float*, int, float*, int*, float*); ++static void ssconv(int, float*, float*, float, int*); ++static void sseigt(float, int, float*, int, float*, float*, float*, int*); ++static void ssaitr(struct ARPACK_arnoldi_update_vars_s*, int, int, float*, float*, float*, int, float*, int, int*, float*); ++static void ssapps(int, int*, int, float*, float*, int, float*, int, float*, float* , int, float*); ++static void ssgets(struct ARPACK_arnoldi_update_vars_s*, int*, int*, float*, float*, float*); ++static void sgetv0(struct ARPACK_arnoldi_update_vars_s *, int, int, int, float*, int, float*, float*, int*, float*); ++static void ssortr(const enum ARPACK_which w, const int apply, const int n, float* x1, float* x2); ++static void ssesrt(const enum ARPACK_which w, const int apply, const int n, float* x, int na, float* a, const int lda); ++static void sstqrb(int n, float* d, float* e, float* z, float* work, int* info); ++ ++enum ARPACK_seupd_type { ++ REGULAR, ++ SHIFTI, ++ BUCKLE, ++ CAYLEY ++}; ++ ++ ++void ++ARPACK_sseupd(struct ARPACK_arnoldi_update_vars_s *V, int rvec, int howmny, int* select, ++ float* d, float* z, int ldz, float sigma, float* resid, float* v, ++ int ldv, int* ipntr, float* workd, float* workl) ++{ ++ const float eps23 = powf(ulp, 2.0f / 3.0f); ++ int j, jj, k; ++ int ibd, ih, ihb, ihd, iq, irz, iw, ldh, ldq, ritz, bounds, next, np; ++ int ierr = 0, int1 = 1, tmp_int = 0, numcnv, reord; ++ float bnorm2, rnorm, temp, temp1, dbl1 = 1.0f; ++ ++ if (V->nconv == 0) { return; } ++ ++ ierr = 0; ++ enum ARPACK_seupd_type TYP = REGULAR; ++ ++ if (V->nconv <= 0) { ++ ierr = -14; ++ } else if (V->n <= 0) { ++ ierr = -1; ++ } else if (V->nev <= 0) { ++ ierr = -2; ++ } else if ((V->ncv <= V->nev) || (V->ncv > V->n)) { ++ ierr = -3; ++ } else if ((V->which != 0) && ++ (V->which != 1) && ++ (V->which != 6) && ++ (V->which != 7) && ++ (V->which != 8)) { ++ ierr = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ ierr = -6; ++ } else if ((rvec) && ((howmny < 0) || (howmny > 2))) { ++ ierr = -15; ++ } else if ((rvec) && (howmny == 2)) { ++ ierr = -16; // NotImplementedError ++ } ++ ++ if ((V->mode == 1) || (V->mode == 2)) { ++ TYP = REGULAR; ++ } else if (V->mode == 3) { ++ TYP = SHIFTI; ++ } else if (V->mode == 4) { ++ TYP = BUCKLE; ++ } else if (V->mode == 5) { ++ TYP = CAYLEY; ++ } else { ++ ierr = -10; ++ } ++ ++ if ((V->mode == 1) && (V->bmat)) { ierr = -11; } ++ if ((V->nev == 1) && (V->which == which_BE)) { ierr = -12; } ++ ++ if (ierr != 0) { ++ V->info = ierr; ++ return; ++ } ++ ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:2*ncv) := generated tridiagonal matrix H ++ // The subdiagonal is stored in workl(2:ncv). ++ // The dead spot is workl(1) but upon exiting ++ // dsaupd stores the B-norm of the last residual ++ // vector in workl(1). We use this !!! ++ // workl(2*ncv+1:2*ncv+ncv) := ritz values ++ // The wanted values are in the first NCONV spots. ++ // workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates ++ // The wanted values are in the first NCONV spots. ++ // NOTE: workl(1:4*ncv) is set by dsaupd and is not ++ // modified by dseupd . ++ // ---------------------------------------------------- ++ // The following is used and set by dseupd . ++ // workl(4*ncv+1:4*ncv+ncv) := used as workspace during ++ // computation of the eigenvectors of H. Stores ++ // the diagonal of H. Upon EXIT contains the NCV ++ // Ritz values of the original system. The first ++ // NCONV spots have the wanted values. If MODE = ++ // 1 or 2 then will equal workl(2*ncv+1:3*ncv). ++ // workl(5*ncv+1:5*ncv+ncv) := used as workspace during ++ // computation of the eigenvectors of H. Stores ++ // the subdiagonal of H. Upon EXIT contains the ++ // NCV corresponding Ritz estimates of the ++ // original system. The first NCONV spots have the ++ // wanted values. If MODE = 1,2 then will equal ++ // workl(3*ncv+1:4*ncv). ++ // workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is ++ // the eigenvector matrix for H as returned by ++ // dsteqr . Not referenced if RVEC = .False. ++ // Ordering follows that of workl(4*ncv+1:5*ncv) ++ // workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := ++ // Workspace. Needed by dsteqr and by dseupd . ++ // GRAND total of NCV*(NCV+8) locations. ++ ++ ih = ipntr[4]; ++ ritz = ipntr[5]; ++ bounds = ipntr[6]; ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ihd = bounds + ldh; ++ ihb = ihd + ldh; ++ iq = ihb + ldh; ++ iw = iq + ldh*V->ncv; ++ next = iw + 2*V->ncv; ++ ipntr[3] = next; ++ ipntr[7] = ihd; ++ ipntr[8] = ihb; ++ ipntr[9] = iq; ++ ++ // irz points to the Ritz values computed ++ // by _seigt before exiting _saup2. ++ // ibd points to the Ritz estimates ++ // computed by _seigt before exiting ++ // _saup2. ++ ++ irz = ipntr[10] + V->ncv; ++ ibd = irz + V->ncv; ++ ++ // RNORM is B-norm of the RESID(1:N). ++ // BNORM2 is the 2 norm of B*RESID(1:N). ++ // Upon exit of dsaupd WORKD(1:N) has ++ // B*RESID(1:N). ++ ++ rnorm = workl[ih]; ++ if (V->bmat) ++ { ++ bnorm2 = snrm2_(&V->n, workd, &int1); ++ } else { ++ bnorm2 = rnorm; ++ } ++ ++ if (rvec) { ++ reord = 0; ++ ++ // Use the temporary bounds array to store indices ++ // These will be used to mark the select array later ++ ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[bounds + j] = j; ++ select[j] = 0; ++ } ++ // 10 ++ ++ // Select the wanted Ritz values. ++ // Sort the Ritz values so that the ++ // wanted ones appear at the tailing ++ // NEV positions of workl(irr) and ++ // workl(iri). Move the corresponding ++ // error estimates in workl(bound) ++ // accordingly. ++ ++ np = V->ncv - V->nev; ++ V->shift = 0; ++ ssgets(V, &V->nev, &np, &workl[irz], &workl[bounds], workl); ++ ++ // Record indices of the converged wanted Ritz values ++ // Mark the select array for possible reordering ++ ++ numcnv = 0; ++ for (j = 1; j <= V->ncv; j++) ++ { ++ temp1 = fmaxf(eps23, fabsf(workl[irz + V->ncv - j])); ++ ++ jj = (int)workl[bounds + V->ncv - j]; ++ ++ if ((numcnv < V->nconv) && (workl[ibd + jj] <= V->tol*temp1)) ++ { ++ select[jj] = 1; ++ numcnv += 1; ++ if (jj > V->nconv - 1) { reord = 1; } ++ } ++ } ++ // 11 ++ ++ // Check the count (numcnv) of converged Ritz values with ++ // the number (nconv) reported by saupd. If these two ++ // are different then there has probably been an error ++ // caused by incorrect passing of the saupd data. ++ ++ if (numcnv != V->nconv) ++ { ++ V->info = -17; ++ return; ++ } ++ ++ // Call LAPACK routine _steqr to compute the eigenvalues and ++ // eigenvectors of the final symmetric tridiagonal matrix H. ++ // Initialize the eigenvector matrix Q to the identity. ++ ++ tmp_int = V->ncv - 1; ++ scopy_(&tmp_int, &workl[ih+1], &int1, &workl[ihb], &int1); ++ scopy_(&V->ncv, &workl[ih+ldh], &int1, &workl[ihd], &int1); ++ ++ ssteqr_("I", &V->ncv, &workl[ihd], &workl[ihb], &workl[iq], &ldq, &workl[iw], &ierr); ++ ++ if (ierr != 0) ++ { ++ V->info = -8; ++ return; ++ } ++ ++ if (reord) ++ { ++ ++ // Reordered the eigenvalues and eigenvectors ++ // computed by _steqr so that the "converged" ++ // eigenvalues appear in the first NCONV ++ // positions of workl(ihd), and the associated ++ // eigenvectors appear in the first NCONV ++ // columns. ++ ++ int leftptr = 0; ++ int rightptr = V->ncv - 1; ++ ++ if (V->ncv > 1) ++ { ++ do ++ { ++ if (select[leftptr]) ++ { ++ ++ // Search, from the left, for the first non-converged Ritz value. ++ ++ leftptr += 1; ++ ++ } else if (!(select[rightptr])) { ++ ++ // Search, from the right, the first converged Ritz value ++ ++ rightptr -= 1; ++ ++ } else { ++ ++ // Swap the Ritz value on the left that has not ++ // converged with the Ritz value on the right ++ // that has converged. Swap the associated ++ // eigenvector of the tridiagonal matrix H as ++ // well. ++ ++ temp = workl[ihd + leftptr]; ++ workl[ihd + leftptr] = workl[ihd + rightptr]; ++ workl[ihd + rightptr] = temp; ++ ++ scopy_(&V->ncv, &workl[iq + V->ncv*leftptr], &int1, &workl[iw], &int1); ++ scopy_(&V->ncv, &workl[iq + V->ncv*rightptr], &int1, &workl[iq + V->ncv*leftptr], &int1); ++ scopy_(&V->ncv, &workl[iw], &int1, &workl[iq + V->ncv*rightptr], &int1); ++ ++ leftptr += 1; ++ rightptr -= 1; ++ } ++ } while (leftptr < rightptr); ++ } ++ } ++ ++ // Load the converged Ritz values into D. ++ ++ scopy_(&V->nconv, &workl[ihd], &int1, d, &int1); ++ ++ } else { ++ ++ // Ritz vectors not required. Load Ritz values into D. ++ ++ scopy_(&V->nconv, &workl[ritz], &int1, d, &int1); ++ scopy_(&V->ncv, &workl[ritz], &int1, &workl[ihd], &int1); ++ } ++ ++ // Transform the Ritz values and possibly vectors and corresponding ++ // Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values ++ // (and corresponding data) are returned in ascending order. ++ ++ if (TYP == REGULAR) ++ { ++ ++ // Ascending sort of wanted Ritz values, vectors and error ++ // bounds. Not necessary if only Ritz values are desired. ++ ++ if (rvec) { ++ ssesrt(which_LA, rvec, V->nconv, d, V->ncv, &workl[iq], ldq); ++ } else { ++ scopy_(&V->ncv, &workl[bounds], &int1, &workl[ihb], &int1); ++ } ++ ++ } else { ++ ++ // * Make a copy of all the Ritz values. ++ // * Transform the Ritz values back to the original system. ++ // For TYPE = 'SHIFTI' the transformation is ++ // lambda = 1/theta + sigma ++ // For TYPE = 'BUCKLE' the transformation is ++ // lambda = sigma * theta / ( theta - 1 ) ++ // For TYPE = 'CAYLEY' the transformation is ++ // lambda = sigma * (theta + 1) / (theta - 1 ) ++ // where the theta are the Ritz values returned by dsaupd. ++ // NOTES: ++ // *The Ritz vectors are not affected by the transformation. ++ // They are only reordered. ++ ++ scopy_(&V->ncv, &workl[ihd], &int1, &workl[iw], &int1); ++ if (TYP == SHIFTI) ++ { ++ for (int k = 0; k < V->ncv; k++) ++ { ++ workl[ihd + k] = 1.0f / workl[ihd + k] + sigma; ++ } ++ } else if (TYP == BUCKLE) { ++ for (int k = 0; k < V->ncv; k++) { ++ workl[ihd + k] = sigma * workl[ihd + k] / (workl[ihd + k] - 1.0f); ++ } ++ } else if (TYP == CAYLEY) { ++ for (int k = 0; k < V->ncv; k++) { ++ workl[ihd + k] = sigma * (workl[ihd + k] + 1.0f) / (workl[ihd + k] - 1.0f); ++ } ++ } ++ ++ // * Store the wanted NCONV lambda values into D. ++ // * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) ++ // into ascending order and apply sort to the NCONV theta ++ // values in the transformed system. We will need this to ++ // compute Ritz estimates in the original system. ++ // * Finally sort the lambda`s into ascending order and apply ++ // to Ritz vectors if wanted. Else just sort lambda`s into ++ // ascending order. ++ // NOTES: ++ // *workl(iw:iw+ncv-1) contain the theta ordered so that they ++ // match the ordering of the lambda. We`ll use them again for ++ // Ritz vector purification. ++ ++ scopy_(&V->nconv, &workl[ihd], &int1, d, &int1); ++ ssortr(which_LA, 1, V->nconv, &workl[ihd], &workl[iw]); ++ if (rvec) { ++ ssesrt(which_LA, rvec, V->nconv, d, V->ncv, &workl[iq], ldq); ++ } else { ++ scopy_(&V->ncv, &workl[bounds], &int1, &workl[ihb], &int1); ++ temp = bnorm2 / rnorm; ++ sscal_(&V->ncv, &temp, &workl[ihb], &int1); ++ ssortr(which_LA, 1, V->nconv, d, &workl[ihb]); ++ } ++ } ++ ++ // Compute the Ritz vectors. Transform the wanted ++ // eigenvectors of the symmetric tridiagonal H by ++ // the Lanczos basis matrix V. ++ ++ if ((rvec) && (howmny == 0)) ++ { ++ ++ // Compute the QR factorization of the matrix representing ++ // the wanted invariant subspace located in the first NCONV ++ // columns of workl(iq, ldq). ++ ++ sgeqr2_(&V->ncv, &V->nconv, &workl[iq], &ldq, &workl[iw + V->ncv], &workl[ihb], &ierr); ++ ++ // * Postmultiply V by Q. ++ // * Copy the first NCONV columns of VQ into Z. ++ // The N by NCONV matrix Z is now a matrix representation ++ // of the approximate invariant subspace associated with ++ // the Ritz values in workl(ihd). ++ ++ sorm2r_("R", "N", &V->n, &V->ncv, &V->nconv, &workl[iq], &ldq, &workl[iw + V->ncv], v, &ldv, &workd[V->n], &ierr); ++ slacpy_("A", &V->n, &V->nconv, v, &ldv, z, &ldz); ++ ++ // In order to compute the Ritz estimates for the Ritz ++ // values in both systems, need the last row of the ++ // eigenvector matrix. Remember, it's in factored form. ++ ++ for (int j = 0; j < V->ncv - 1; j++) ++ { ++ workl[ihb + j] = 0.0f; ++ } ++ workl[ihb + V->ncv - 1] = 1.0f; ++ sorm2r_("L", "T", &V->ncv, &int1, &V->nconv, &workl[iq], &ldq, &workl[iw + V->ncv], &workl[ihb], &V->ncv, &temp, &ierr); ++ ++ // Make a copy of the last row into ++ // workl(iw+ncv:iw+2*ncv), as it is needed again in ++ // the Ritz vector purification step below ++ ++ for (int j = 0; j < V->nconv; j++) ++ { ++ workl[iw + V->ncv + j] = workl[ihb + j]; ++ } ++ // 67 ++ ++ } else if ((rvec) && (howmny == 2)) { ++ // Not yet implemented ++ ; ++ } ++ ++ if ((TYP == REGULAR) && (rvec)) ++ { ++ for (j = 0; j < V->ncv; j++) ++ { ++ workl[ihb + j] = rnorm * fabsf(workl[ihb + j]); ++ } ++ ++ } else if ((TYP != REGULAR) && (rvec)) { ++ ++ // * Determine Ritz estimates of the theta. ++ // If RVEC = .true. then compute Ritz estimates ++ // of the theta. ++ // If RVEC = .false. then copy Ritz estimates ++ // as computed by dsaupd . ++ // * Determine Ritz estimates of the lambda. ++ ++ ++ sscal_(&V->ncv, &bnorm2, &workl[ihb], &int1); ++ ++ for (k = 0; k < V->ncv; k++) ++ { ++ if (TYP == SHIFTI) ++ { ++ workl[ihb + k] = fabsf(workl[ihb + k]) / powf(workl[iw + k], 2.0f); ++ } else if (TYP == BUCKLE) { ++ workl[ihb + k] = sigma * fabsf(workl[ihb + k]) / powf(workl[iw + k] - 1.0f, 2.0f); ++ } else if (TYP == CAYLEY) { ++ workl[ihb + k] = fabsf(workl[ihb + k] / workl[iw + k] * (workl[iw + k] - 1.0f)); ++ } ++ } ++ // 80, 90, 100 ++ } ++ ++ // Ritz vector purification step. Formally perform ++ // one of inverse subspace iteration. Only used ++ // for MODE = 3,4,5. See reference 7 ++ ++ if ((rvec) && ((TYP == SHIFTI) || (TYP == CAYLEY))) ++ { ++ for (k = 0; k < V->nconv; k++) ++ { ++ workl[iw + k] = workl[iw + V->ncv + k] / workl[iw + k]; ++ } ++ // 110 ++ } else if ((rvec) && (TYP == BUCKLE)) ++ { ++ for (k = 0; k < V->nconv; k++) ++ { ++ workl[iw + k] = workl[iw + V->ncv + k] / (workl[iw + k] - 1.0f); ++ } ++ // 120 ++ } ++ ++ if ((rvec) && (TYP != REGULAR)) ++ { ++ sger_(&V->n, &V->nconv, &dbl1, resid, &int1, &workl[iw], &int1, z, &ldz); ++ } ++ ++ return; ++} ++ ++ ++void ++ARPACK_ssaupd(struct ARPACK_arnoldi_update_vars_s *V, float* resid, float* v, int ldv, ++ int* ipntr, float* workd, float* workl) ++{ ++ ++ int bounds = 0, ih = 0, iq = 0, iw = 0, j = 0, ldh = 0, ldq = 0, next = 0, ritz = 0; ++ ++ if (V->ido == ido_FIRST) ++ { ++ if (V->n <= 0) { ++ V->info = -1; ++ } else if (V->nev <= 0) { ++ V->info = -2; ++ } else if ((V->ncv < V->nev + 1) || (V->ncv > V->n)) { ++ V->info = -3; ++ } else if (V->maxiter <= 0) { ++ V->info = -4; ++ } else if ((V->which != 0) && ++ (V->which != 1) && ++ (V->which != 6) && ++ (V->which != 7) && ++ (V->which != 8)) { ++ V->info = -5; ++ } else if ((V->bmat != 0) && (V->bmat != 1)) { ++ V->info = -6; ++ } else if ((V->mode < 1) || (V->mode > 5)) { ++ V->info = -10; ++ } else if ((V->mode == 1) && (V->bmat == 1)) { ++ V->info = -11; ++ } else if ((V->shift != 0) && (V->shift != 1)) { ++ V->info = -12; ++ } else if ((V->nev == 1) && (V->which == which_BE)) { ++ V->info = -13; ++ } ++ ++ if (V->info < 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ if (V->tol <= 0.0f) { V->tol = ulp; } ++ ++ // NP is the number of additional steps to ++ // extend the length NEV Lanczos factorization. ++ V->np = V->ncv - V->nev; ++ ++ // Zero out internal workspace ++ for (j = 0; j < (V->ncv)*((V->ncv) + 8); j++) { workl[j] = 0.0f; } ++ } ++ ++ // Pointer into WORKL for address of H, RITZ, BOUNDS, Q ++ // etc... and the remaining workspace. ++ // Also update pointer to be used on output. ++ // Memory is laid out as follows: ++ // workl(1:2*ncv) := generated tridiagonal matrix ++ // workl(2*ncv+1:2*ncv+ncv) := ritz values ++ // workl(3*ncv+1:3*ncv+ncv) := computed error bounds ++ // workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q ++ // workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace ++ ++ ldh = V->ncv; ++ ldq = V->ncv; ++ ih = 0; ++ ritz = ih + 2*ldh; ++ bounds = ritz + V->ncv; ++ iq = bounds + V->ncv; ++ iw = iq + (V->ncv)*(V->ncv); ++ next = iw + 3*(V->ncv); ++ ++ ipntr[3] = next; ++ ipntr[4] = ih; ++ ipntr[5] = ritz; ++ ipntr[6] = bounds; ++ ipntr[10] = iw; ++ ++ // Carry out the Implicitly restarted Lanczos Iteration. ++ ssaup2(V, resid, v, ldv, &workl[ih], ldh, &workl[ritz], &workl[bounds], ++ &workl[iq], ldq, &workl[iw], ipntr, workd); ++ ++ /*-------------------------------------------------* ++ | ido .ne. 99 implies use of reverse communication | ++ | to compute operations involving OP or shifts. | ++ *-------------------------------------------------*/ ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info < 0) { return; } ++ if (V->info == 2) { V->info = 3; } ++ ++ return; ++} ++ ++ ++void ++ssaup2(struct ARPACK_arnoldi_update_vars_s *V, float* resid, float* v, int ldv, ++ float* h, int ldh, float* ritz, float* bounds, ++ float* q, int ldq, float* workl, int* ipntr, float* workd) ++{ ++ int int1 = 1, j, tmp_int, nevd2, nevm2; ++ const float eps23 = powf(ulp, 2.0f / 3.0f); ++ float temp = 0.0f; ++ // Initialize to silence the compiler warning ++ enum ARPACK_which temp_which = which_LM; ++ ++ if (V->ido == ido_FIRST) ++ { ++ // nev0 and np0 are integer variables hold the initial values of NEV & NP ++ V->aup2_nev0 = V->nev; ++ V->aup2_np0 = V->np; ++ ++ // kplusp is the bound on the largest Lanczos factorization built. ++ // nconv is the current number of "converged" eigenvalues. ++ // iter is the counter on the current iteration step. ++ V->aup2_kplusp = V->nev + V->np; ++ V->nconv = 0; ++ V->aup2_iter = 0; ++ ++ // Set flags for computing the first NEV steps of the Lanczos factorization. | ++ ++ V->aup2_getv0 = 1; ++ V->aup2_update = 0; ++ V->aup2_cnorm = 0; ++ V->aup2_ushift = 0; ++ ++ if (V->info != 0) ++ { ++ // User provides the initial residual vector. ++ V->aup2_initv = 1; ++ V->info = 0; ++ } else { ++ V->aup2_initv = 0; ++ } ++ } ++ ++ // Get a possibly random starting vector and ++ // force it into the range of the operator OP. ++ ++ if (V->aup2_getv0) ++ { ++ V->getv0_itry = 1; ++ sgetv0(V, V->aup2_initv, V->n, 0, v, ldv, resid, &V->aup2_rnorm, ipntr, workd); ++ if (V->ido != ido_DONE) { return; } ++ if (V->aup2_rnorm == 0.0f) ++ { ++ V->info = -9; ++ V->ido = ido_DONE; ++ return; ++ } ++ V->aup2_getv0 = 0; ++ V->ido = ido_FIRST; ++ } ++ ++ // Back from reverse communication : ++ // continue with update step ++ ++ if (V->aup2_update) { goto LINE20; } ++ ++ // Back from computing user specified shifts ++ ++ if (V->aup2_ushift) { goto LINE50; } ++ ++ // Back from computing residual norm ++ // at the end of the current iteration ++ ++ if (V->aup2_cnorm) { goto LINE100; } ++ ++ // Compute the first NEV steps of the Arnoldi factorization ++ ++ ssaitr(V, 0, V->aup2_nev0, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ // ido .ne. 99 implies use of reverse communication ++ // to compute operations involving OP and possibly B ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // ++ // M A I N ARNOLDI I T E R A T I O N L O O P ++ // Each iteration implicitly restarts the Arnoldi ++ // factorization in place. ++ // ++ ++LINE1000: ++ ++ V->aup2_iter += 1; ++ ++ // Compute NP additional steps of the Lanczos factorization. ++ ++ V->ido = ido_FIRST; ++ ++LINE20: ++ V->aup2_update = 1; ++ ++ ssaitr(V, V->nev, V->np, resid, &V->aup2_rnorm, v, ldv, h, ldh, ipntr, workd); ++ ++ /*--------------------------------------------------* ++ | ido .ne. 99 implies use of reverse communication | ++ | to compute operations involving OP and possibly B | ++ *--------------------------------------------------*/ ++ ++ if (V->ido != ido_DONE) { return; } ++ ++ if (V->info > 0) ++ { ++ V->np = V->info; ++ V->iter = V->aup2_iter; ++ V->info = -9999; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->aup2_update = 0; ++ ++ // Compute the eigenvalues and corresponding error bounds ++ // of the current symmetric tridiagonal matrix. ++ sseigt(V->aup2_rnorm, V->aup2_kplusp, h, ldh, ritz, bounds, workl, &V->info); ++ ++ if (V->info != 0) ++ { ++ V->info = -8; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Make a copy of eigenvalues and corresponding error ++ // bounds obtained from _seigt. ++ ++ scopy_(&V->aup2_kplusp, ritz, &int1, &workl[V->aup2_kplusp], &int1); ++ scopy_(&V->aup2_kplusp, bounds, &int1, &workl[2*V->aup2_kplusp], &int1); ++ ++ // Select the wanted Ritz values and their bounds ++ // to be used in the convergence test. ++ // The selection is based on the requested number of ++ // eigenvalues instead of the current NEV and NP to ++ // prevent possible misconvergence. ++ // * Wanted Ritz values := RITZ(NP+1:NEV+NP) ++ // * Shifts := RITZ(1:NP) := WORKL(1:NP) ++ ++ V->nev = V->aup2_nev0; ++ V->np = V->aup2_np0; ++ ++ ssgets(V, &V->nev, &V->np, ritz, bounds, workl); ++ ++ // Convergence test ++ ++ scopy_(&V->nev, &bounds[V->np], &int1, &workl[V->np], &int1); ++ ssconv(V->nev, &ritz[V->np], &workl[V->np], V->tol, &V->nconv); ++ ++ // Count the number of unwanted Ritz values that have zero ++ // Ritz estimates. If any Ritz estimates are equal to zero ++ // then a leading block of H of order equal to at least ++ // the number of Ritz values with zero Ritz estimates has ++ // split off. None of these Ritz values may be removed by ++ // shifting. Decrease NP the number of shifts to apply. If ++ // no shifts may be applied, then prepare to exit ++ ++ tmp_int = V->np; ++ for (j = 0; j < tmp_int; j++) ++ { ++ if (bounds[j] == 0.0f) ++ { ++ V->np -= 1; ++ V->nev += 1; ++ } ++ } ++ // 30 ++ ++ if ((V->nconv >= V->aup2_nev0) || (V->aup2_iter > V->maxiter) || (V->np == 0)) ++ { ++ // Prepare to exit. Put the converged Ritz values ++ // and corresponding bounds in RITZ(1:NCONV) and ++ // BOUNDS(1:NCONV) respectively. Then sort. Be ++ // careful when NCONV > NP since we don't want to ++ // swap overlapping locations. ++ ++ if (V->which == which_BE) ++ { ++ ++ // Both ends of the spectrum are requested. ++ // Sort the eigenvalues into algebraically decreasing ++ // order first then swap low end of the spectrum next ++ // to high end in appropriate locations. ++ // NOTE: when np < floor(nev/2) be careful not to swap ++ // overlapping locations. ++ ++ ssortr(which_SA, 1, V->aup2_kplusp, ritz, bounds); ++ nevd2 = V->aup2_nev0 / 2; ++ nevm2 = V->aup2_nev0 - nevd2; ++ if (V->nev > 1) ++ { ++ V->np = V->aup2_kplusp - V->aup2_nev0; ++ ++ tmp_int = (nevd2 < V->np ? nevd2 : V->np); ++ int tmp_int2 = V->aup2_kplusp - tmp_int; ++ ++ sswap_(&tmp_int, &ritz[nevm2], &int1, &ritz[tmp_int2], &int1); ++ sswap_(&tmp_int, &bounds[nevm2], &int1, &bounds[tmp_int2], &int1); ++ } ++ ++ } else { ++ ++ // LM, SM, LA, SA case. ++ // Sort the eigenvalues of H into the an order that ++ // is opposite to WHICH, and apply the resulting ++ // order to BOUNDS. The eigenvalues are sorted so ++ // that the wanted part are always within the first ++ // NEV locations. ++ ++ if (V->which == which_LM) { temp_which = which_SM; } ++ if (V->which == which_SM) { temp_which = which_LM; } ++ if (V->which == which_LA) { temp_which = which_SA; } ++ if (V->which == which_SA) { temp_which = which_LA; } ++ ++ ssortr(temp_which, 1, V->aup2_kplusp, ritz, bounds); ++ } ++ ++ // Scale the Ritz estimate of each Ritz value ++ // by 1 / max(eps23,magnitude of the Ritz value). ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmaxf(eps23, fabsf(ritz[j])); ++ bounds[j] = bounds[j] / temp; ++ } ++ // 35 ++ ++ // Sort the Ritz values according to the scaled Ritz ++ // estimates. This will push all the converged ones ++ // towards the front of ritzr, ritzi, bounds ++ // (in the case when NCONV < NEV.) ++ ++ ssortr(which_LA, 1, V->aup2_nev0, bounds, ritz); ++ ++ // Scale the Ritz estimate back to its original ++ // value. ++ ++ for (j = 0; j < V->aup2_nev0; j++) ++ { ++ temp = fmaxf(eps23, fabsf(ritz[j])); ++ bounds[j] = bounds[j] * temp; ++ } ++ // 40 ++ ++ // Sort the "converged" Ritz values again so that ++ // the "threshold" values and their associated Ritz ++ // estimates appear at the appropriate position in ++ // ritz and bound. ++ ++ if (V->which == which_BE) ++ { ++ ++ // Sort the "converged" Ritz values in increasing ++ // order. The "threshold" values are in the ++ // middle. ++ ++ ssortr(which_LA, 1, V->nconv, ritz, bounds); ++ } else { ++ ++ // In LM, SM, LA, SA case, sort the "converged" ++ // Ritz values according to WHICH so that the ++ // "threshold" value appears at the front of ++ // ritz. ++ ++ ssortr(V->which, 1, V->nconv, ritz, bounds); ++ } ++ ++ // Use h( 1,1 ) as storage to communicate ++ // rnorm to _seupd if needed ++ ++ h[0] = V->aup2_rnorm; ++ ++ // Max iterations have been exceeded. ++ ++ if ((V->aup2_iter > V->maxiter) && (V->nconv < V->nev)) ++ { ++ V->info = 1; ++ } ++ ++ // No shifts to apply. ++ ++ if ((V->np == 0) && (V->nconv < V->aup2_nev0)) ++ { ++ V->info = 2; ++ } ++ ++ V->np = V->nconv; ++ V->nev = V->nconv; ++ V->iter = V->aup2_iter; ++ V->ido = ido_DONE; ++ return; ++ ++ } else if ((V->nconv < V->nev) && (V->shift == 1)) { ++ ++ // Do not have all the requested eigenvalues yet. ++ // To prevent possible stagnation, adjust the number ++ // of Ritz values and the shifts. ++ ++ int nevbef = V->nev; ++ V->nev += (V->nconv > (V->np / 2) ? (V->np / 2) : V->nconv); ++ if ((V->nev == 1) && (V->aup2_kplusp >= 6)) ++ { ++ V->nev = V->aup2_kplusp / 2; ++ } else if ((V->nev == 1) && (V->aup2_kplusp > 2)) ++ { ++ V->nev = 2; ++ } ++ V->np = V->aup2_kplusp - V->nev; ++ ++ // If the size of NEV was just increased resort the eigenvalues. ++ ++ if (nevbef < V->nev) ++ { ++ ssgets(V, &V->nev, &V->np, ritz, bounds, workl); ++ } ++ } ++ ++ if (V->shift == 0) ++ { ++ // User specified shifts: reverse communication to ++ // compute the shifts. They are returned in the first ++ // NP locations of WORKL. ++ ++ V->aup2_ushift = 1; ++ V->ido = ido_USER_SHIFT; ++ return; ++ } ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // User specified shifts are returned ++ // in WORKL(1:*NP) ++ ++ V->aup2_ushift = 0; ++ ++ // Move the NP shifts to the first NP locations of RITZ to ++ // free up WORKL. This is for the non-exact shift case; ++ // in the exact shift case, dsgets already handles this. ++ ++ if (V->shift == 0) { scopy_(&V->np, workl, &int1, ritz, &int1); } ++ ++ /*--------------------------------------------------------* ++ | Apply the NP0 implicit shifts by QR bulge chasing. | ++ | Each shift is applied to the entire tridiagonal matrix. | ++ | The first 2*N locations of WORKD are used as workspace. | ++ | After dsapps is done, we have a Lanczos | ++ | factorization of length NEV. | ++ *--------------------------------------------------------*/ ++ ++ ssapps(V->n, &V->nev, V->np, ritz, v, ldv, h, ldh, resid, q, ldq, workd); ++ ++ // Compute the B-norm of the updated residual. ++ // Keep B*RESID in WORKD(1:N) to be used in ++ // the first step of the next call to dsaitr. ++ ++ V->aup2_cnorm = 1; ++ ++ if (V->bmat) ++ { ++ scopy_(&V->n, resid, &int1, &workd[V->n], &int1); ++ ipntr[0] = V->n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*RESID ++ ++ return; ++ } else { ++ scopy_(&V->n, resid, &int1, workd, &int1); ++ } ++ ++LINE100: ++ ++ /*---------------------------------* ++ | Back from reverse communication; | ++ | WORKD(1:N) := B*RESID | ++ *---------------------------------*/ ++ ++ if (V->bmat) ++ { ++ V->aup2_rnorm = sqrtf(fabsf(sdot_(&V->n, resid, &int1, workd, &int1))); ++ } else { ++ V->aup2_rnorm = snrm2_(&V->n, resid, &int1); ++ } ++ ++ V->aup2_cnorm = 0; ++ ++ goto LINE1000; ++ ++ // ++ // E N D O F M A I N I T E R A T I O N L O O P ++ // ++ ++} ++ ++ ++void ++ssconv(int n, float *ritz, float *bounds, float tol, int* nconv) ++{ ++ const float eps23 = powf(ulp, 2.0f / 3.0f); ++ float temp = 0.0f; ++ ++ *nconv = 0; ++ // Convergence test ++ for (int i = 0; i < n; i++) ++ { ++ temp = fmaxf(eps23, fabsf(ritz[i])); ++ if (fabsf(bounds[i]) <= tol * temp) { *nconv += 1; } ++ } ++ ++ return; ++} ++ ++ ++void ++sseigt(float rnorm, int n, float* h, int ldh, float* eig, float* bounds, ++ float* workl, int* ierr) ++{ ++ int int1 = 1, tmp_int; ++ scopy_(&n, &h[ldh], &int1, eig, &int1); ++ tmp_int = n - 1; ++ scopy_(&tmp_int, &h[1], &int1, workl, &int1); ++ sstqrb(n, eig, workl, bounds, &workl[n], ierr); ++ if (*ierr != 0) { return; } ++ for (int k = 0; k < n; k++) { bounds[k] = rnorm * fabsf(bounds[k]); } ++ return; ++} ++ ++ ++void ++ssaitr(struct ARPACK_arnoldi_update_vars_s *V, int k, int np, float* resid, float* rnorm, ++ float* v, int ldv, float* h, int ldh, int* ipntr, float* workd) ++{ ++ int i, infol, ipj, irj, ivj, jj, n, tmp_int; ++ const float sq2o2 = sqrtf(2.0f) / 2.0f; ++ ++ int int1 = 1; ++ float dbl1 = 1.0f, dbl0 = 0.0f, dblm1 = -1.0f, temp1; ++ ++ n = V->n; // n is constant, this is just for typing convenience ++ ipj = 0; ++ irj = ipj + n; ++ ivj = irj + n; ++ ++ if (V->ido == ido_FIRST) ++ { ++ ++ // Initial call to this routine ++ ++ V->aitr_j = k; ++ V->info = 0; ++ V->aitr_step3 = 0; ++ V->aitr_step4 = 0; ++ V->aitr_orth1 = 0; ++ V->aitr_orth2 = 0; ++ V->aitr_restart = 0; ++ } ++ ++ // When in reverse communication mode one of: ++ // STEP3, STEP4, ORTH1, ORTH2, RSTART ++ // will be .true. when .... ++ // STEP3: return from computing OP*v_{j}. ++ // STEP4: return from computing B-norm of OP*v_{j} ++ // ORTH1: return from computing B-norm of r_{j+1} ++ // ORTH2: return from computing B-norm of ++ // correction to the residual vector. ++ // RSTART: return from OP computations needed by ++ // dgetv0. ++ ++ if (V->aitr_step3) { goto LINE50; } ++ if (V->aitr_step4) { goto LINE60; } ++ if (V->aitr_orth1) { goto LINE70; } ++ if (V->aitr_orth2) { goto LINE90; } ++ if (V->aitr_restart) { goto LINE30; } ++ ++ // Else this is the first step ++ ++ // ++ // A R N O L D I I T E R A T I O N L O O P ++ // ++ // Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) ++ ++LINE1000: ++ ++ // Check for exact zero. Equivalent to determining whether ++ // a j-step Arnoldi factorization is present. ++ ++ if (*rnorm > 0.0f) { goto LINE40; } ++ ++ // Invariant subspace found, generate a new starting ++ // vector which is orthogonal to the current Arnoldi ++ // basis and continue the iteration. ++ ++ V->getv0_itry = 1; ++ ++LINE20: ++ V->aitr_restart = 1; ++ V->ido = ido_FIRST; ++ ++LINE30: ++ ++ // If in reverse communication mode and aitr_restart = 1, flow returns here. ++ ++ sgetv0(V, 0, n, V->aitr_j, v, ldv, resid, rnorm, ipntr, workd); ++ ++ if (V->ido != ido_DONE) { return; } ++ V->aitr_ierr = V->info; ++ if (V->aitr_ierr < 0) ++ { ++ V->getv0_itry += 1; ++ if (V->getv0_itry <= 3) { goto LINE20; } ++ ++ // Give up after several restart attempts. ++ // Set INFO to the size of the invariant subspace ++ // which spans OP and exit. ++ ++ V->info = V->aitr_j; ++ V->ido = ido_DONE; ++ return; ++ } ++ ++LINE40: ++ ++ // STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm ++ // Note that p_{j} = B*r_{j-1}. In order to avoid overflow ++ // when reciprocating a small RNORM, test against lower ++ // machine bound. ++ ++ scopy_(&n, resid, &int1, &v[ldv*(V->aitr_j)], &int1); ++ if (*rnorm >= unfl) ++ { ++ temp1 = 1.0f / *rnorm; ++ sscal_(&n, &temp1, &v[ldv*(V->aitr_j)], &int1); ++ sscal_(&n, &temp1, &workd[ipj], &int1); ++ } else { ++ slascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &v[ldv*(V->aitr_j)], &n, &infol); ++ slascl_("G", &i, &i, rnorm, &dbl1, &n, &int1, &workd[ipj], &n, &infol); ++ } ++ ++ // STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} ++ // Note that this is not quite yet r_{j}. See STEP 4 ++ ++ V->aitr_step3 = 1; ++ scopy_(&n, &v[ldv*(V->aitr_j)], &int1, &workd[ivj], &int1); ++ ipntr[0] = ivj; ++ ipntr[1] = irj; ++ ipntr[2] = ipj; ++ V->ido = ido_OPX; ++ ++ // Exit in order to compute OP*v_{j} ++ ++ return; ++ ++LINE50: ++ ++ // Back from reverse communication; ++ // WORKD(IRJ:IRJ+N-1) := OP*v_{j} ++ ++ V->aitr_step3 = 0; ++ ++ // Put another copy of OP*v_{j} into RESID. ++ ++ scopy_(&n, &workd[irj], &int1, resid, &int1); ++ ++ // STEP 4: Finish extending the symmetric ++ // Arnoldi to length j. If MODE = 2 ++ // then B*OP = B*inv(B)*A = A and ++ // we don't need to compute B*OP. ++ // NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is ++ // assumed to have A*v_{j}. ++ ++ if (V->mode == 2) { goto LINE65; } ++ if (V->bmat) ++ { ++ V->aitr_step4 = 1; ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*OP*v_{j} ++ ++ return; ++ } else { ++ scopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE60: ++ ++ // Back from reverse communication; ++ // WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. ++ ++ V->aitr_step4 = 0; ++ ++ // The following is needed for STEP 5. ++ // Compute the B-norm of OP*v_{j}. ++ ++LINE65: ++ ++ if (V->mode == 2) ++ { ++ ++ // Note that the B-norm of OP*v_{j} ++ // is the inv(B)-norm of A*v_{j}. ++ ++ V->aitr_wnorm = sdot_(&n, resid, &int1, &workd[ivj], &int1); ++ V->aitr_wnorm = sqrtf(fabsf(V->aitr_wnorm)); ++ } else if (V->bmat) { ++ V->aitr_wnorm = sdot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_wnorm = sqrtf(fabsf(V->aitr_wnorm)); ++ } else { ++ V->aitr_wnorm = snrm2_(&n, resid, &int1); ++ } ++ ++ // Compute the j-th residual corresponding ++ // to the j step factorization. ++ // Use Classical Gram Schmidt and compute: ++ // w_{j} <- V_{j}^T * B * OP * v_{j} ++ // r_{j} <- OP*v_{j} - V_{j} * w_{j} ++ ++ // Compute the j Fourier coefficients w_{j} ++ // WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. ++ tmp_int = V->aitr_j + 1; ++ if (V->mode != 2) ++ { ++ sgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &workd[irj], &int1); ++ } else { ++ sgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ivj], &int1, &dbl0, &workd[irj], &int1); ++ } ++ ++ // Orthogonalize r_{j} against V_{j}. ++ // RESID contains OP*v_{j}. See STEP 3. ++ ++ sgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &workd[irj], &int1, &dbl1, resid, &int1); ++ ++ // Extend H to have j rows and columns. ++ ++ h[V->aitr_j + ldh] = workd[irj + V->aitr_j]; ++ ++ if ((V->aitr_j == 0) || (V->aitr_restart)) ++ { ++ h[V->aitr_j] = 0.0f; ++ } else { ++ h[V->aitr_j] = *rnorm; ++ } ++ ++ V->aitr_orth1 = 1; ++ V->aitr_iter = 0; ++ ++ if (V->bmat) ++ { ++ scopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j} ++ ++ return; ++ } else { ++ scopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE70: ++ ++ // Back from reverse communication if ORTH1 = .true. ++ // WORKD(IPJ:IPJ+N-1) := B*r_{j}. ++ ++ V->aitr_orth1 = 0; ++ ++ // Compute the B-norm of r_{j}. ++ ++ if (V->bmat) ++ { ++ *rnorm = sdot_(&n, resid, &int1, &workd[ipj], &int1); ++ *rnorm = sqrtf(fabsf(*rnorm)); ++ } else { ++ *rnorm = snrm2_(&n, resid, &int1); ++ } ++ ++ // STEP 5: Re-orthogonalization / Iterative refinement phase ++ // Maximum NITER_ITREF tries. ++ // ++ // s = V_{j}^T * B * r_{j} ++ // r_{j} = r_{j} - V_{j}*s ++ // alphaj = alphaj + s_{j} ++ // ++ // The stopping criteria used for iterative refinement is ++ // discussed in Parlett's book SEP, page 107 and in Gragg & ++ // Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. ++ // Determine if we need to correct the residual. The goal is ++ // to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || ++ ++ if (*rnorm > sq2o2*V->aitr_wnorm) { goto LINE100; } ++ ++ // Enter the Iterative refinement phase. If further ++ // refinement is necessary, loop back here. The loop ++ // variable is ITER. Perform a step of Classical ++ // Gram-Schmidt using all the Arnoldi vectors V_{j} ++ ++LINE80: ++ ++ // Compute V_{j}^T * B * r_{j}. ++ // WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). ++ tmp_int = V->aitr_j + 1; ++ sgemv_("T", &n, &tmp_int, &dbl1, v, &ldv, &workd[ipj], &int1, &dbl0, &workd[irj], &int1); ++ ++ // Compute the correction to the residual: ++ // r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). ++ // The correction to H is v(:,1:J)*H(1:J,1:J) ++ // + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. ++ ++ sgemv_("N", &n, &tmp_int, &dblm1, v, &ldv, &workd[irj], &int1, &dbl1, resid, &int1); ++ ++ if ((V->aitr_j == 0) || (V->aitr_restart)) ++ { ++ h[V->aitr_j] = 0.0f; ++ } ++ h[V->aitr_j + ldh] += workd[irj + V->aitr_j]; ++ ++ V->aitr_orth2 = 1; ++ ++ if (V->bmat) ++ { ++ scopy_(&n, resid, &int1, &workd[irj], &int1); ++ ipntr[0] = irj; ++ ipntr[1] = ipj; ++ V->ido = ido_BX; ++ ++ // Exit in order to compute B*r_{j}. ++ // r_{j} is the corrected residual. ++ ++ return; ++ } else { ++ scopy_(&n, resid, &int1, &workd[ipj], &int1); ++ } ++ ++LINE90: ++ ++ // Back from reverse communication if ORTH2 = .true. ++ ++ // Compute the B-norm of the corrected residual r_{j}. ++ ++ if (V->bmat) ++ { ++ V->aitr_rnorm1 = sdot_(&n, resid, &int1, &workd[ipj], &int1); ++ V->aitr_rnorm1 = sqrtf(fabsf(V->aitr_rnorm1)); ++ } else { ++ V->aitr_rnorm1 = snrm2_(&n, resid, &int1); ++ } ++ ++ // Determine if we need to perform another ++ // step of re-orthogonalization. ++ ++ if (V->aitr_rnorm1 > sq2o2*(*rnorm)) ++ { ++ ++ // No need for further refinement. ++ ++ *rnorm = V->aitr_rnorm1; ++ ++ } else { ++ ++ // Another step of iterative refinement step is required. ++ ++ *rnorm = V->aitr_rnorm1; ++ V->aitr_iter += 1; ++ if (V->aitr_iter < 2) { goto LINE80; } ++ ++ // Otherwise RESID is numerically in the span of V ++ ++ for (jj = 0; jj < n; jj++) ++ { ++ resid[jj] = 0.0f; ++ } ++ *rnorm = 0.0f; ++ } ++ ++ // Branch here directly if iterative refinement ++ // wasn't necessary or after at most NITER_REF ++ // steps of iterative refinement. ++ ++LINE100: ++ ++ V->aitr_restart = 0; ++ V->aitr_orth2 = 0; ++ ++ // Make sure the last off-diagonal element is non negative ++ // If not perform a similarity transformation on H(1:j,1:j) ++ // and scale v(:,j) by -1. ++ ++ if (h[V->aitr_j] < 0.0f) ++ { ++ h[V->aitr_j] = -h[V->aitr_j]; ++ if (V->aitr_j < k + np - 1) ++ { ++ sscal_(&n, &dblm1, &v[V->aitr_j + 1], &int1); ++ } else { ++ sscal_(&n, &dblm1, resid, &int1); ++ } ++ } ++ ++ // STEP 6: Update j = j+1; Continue ++ ++ V->aitr_j += 1; ++ if (V->aitr_j >= k + np) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Loop back to extend the factorization by another step. ++ ++ goto LINE1000; ++ ++} ++ ++ ++void ++ssapps(int n, int* kev, int np, float* shift, float* v, int ldv, float* h, int ldh, ++ float* resid, float* q, int ldq, float* workd) ++{ ++ int i, iend, istart, jj, kplusp, tmp_int, int1 = 1; ++ float a1, a2, a3, a4, c, f, g, r, s, sigma, tst1; ++ float dbl0 = 0.0f, dbl1 = 1.0f, dblm1 = -1.0f; ++ ++ iend = 0; ++ kplusp = *kev + np; ++ ++ // Initialize Q to the identity to accumulate ++ // the rotations and reflections ++ ++ slaset_("A", &kplusp, &kplusp, &dbl0, &dbl1, q, &ldq); ++ ++ // Quick return if there are no shifts to apply ++ ++ if (np == 0) { return; } ++ ++ for (jj = 0; jj < np; jj++) ++ { ++ sigma = shift[jj]; ++ ++ // Check for splitting and deflation. Currently we consider ++ // an off-diagonal element h(i+1,1) negligible if ++ // h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) ++ // for i=1:KEV+NP-1. ++ // If above condition tests true then we set h(i+1,1) = 0. ++ // Note that h(1:KEV+NP,1) are assumed to be non negative. ++ ++ istart = 0; ++ while (istart < kplusp - 1) ++ { ++ ++ for (iend = istart; iend < kplusp - 1; iend++) ++ { ++ tst1 = fabsf(h[iend + ldh]) + fabsf(h[iend + 1 + ldh]); ++ if (h[iend + 1] <= ulp * tst1) ++ { ++ h[iend + 1] = 0.0f; ++ break; ++ } ++ } ++ ++ // Scalar block, skipping, correct the sign if necessary ++ if (istart == iend) ++ { ++ istart += 1; ++ if (h[iend] < 0.0f) ++ { ++ h[iend] = -h[iend]; ++ sscal_(&kplusp, &dblm1, &q[ldq*(iend)], &int1); ++ } ++ continue; ++ } ++ ++ // We have a valid block [istart, iend] inclusive ++ f = h[istart + ldh] - sigma; ++ g = h[istart + 1]; ++ ++ for (i = istart; i < iend; i++) ++ { ++ // Applying the plane rotations that create and chase the bulge X ++ // ++ // [c, s] [ x x ] [c, -s] [ x x X ] ++ // [-s, c] [ x x x ] [s, c] [ x x x ] ++ // [ x x x ] => [ X x x x ] ++ // [ x x x ] [ x x x ] ++ // [ ...] [ ...] ++ // ++ // dlartgp (instead of dlartg) is used to make sure that the ++ // off-diagonal elements stay non-negative, (cf. F77 code for ++ // manual handling). ++ ++ // a1 a2 ++ // [c, s] [ k m ] [c, -s] [ c*k + s*m, s*k + c*m] [c, -s] ++ // [-s, c] [ m n ] [s, c] [-s*k + c*m, -s*m + c*n] [s, c] ++ // a3 a4 ++ ++ slartgp_(&f, &g, &c, &s, &r); ++ if (i > istart) ++ { ++ h[i] = r; ++ } ++ a1 = c*h[i + ldh] + s*h[i + 1]; ++ a2 = c*h[i + 1] + s*h[i + 1 + ldh]; ++ a4 = c*h[i + 1 + ldh] - s*h[i + 1]; ++ a3 = c*h[i + 1] - s*h[i + ldh]; ++ h[i + ldh] = c*a1 + s*a2; // h[i , i ] ++ h[i + 1 + ldh] = c*a4 - s*a3; // h[i+1, i+1] ++ h[i + 1] = c*a3 + s*a4; // h[i+1, i ] ++ ++ // Accumulate the rotation also in Q ++ tmp_int = (i + jj + 2 > kplusp ? kplusp : i + jj + 2); ++ srot_(&tmp_int, &q[ldq*i], &int1, &q[ldq*(i+1)], &int1, &c, &s); ++ ++ if (i < iend - 1) ++ { ++ // g is the bulge created by the rotation ++ f = h[i + 1]; ++ g = s*h[i + 2]; ++ h[i + 2] = c*h[i + 2]; ++ } ++ } ++ istart = iend + 1; ++ if (h[iend] < 0.0f) ++ { ++ h[iend] = -h[iend]; ++ sscal_(&kplusp, &dblm1, &q[ldq*(iend)], &int1); ++ } ++ } ++ } ++ // 90 ++ ++ // All shifts have been applied. Check for ++ // more possible deflation that might occur ++ // after the last shift is applied. ++ ++ for (i = 0; i < kplusp - 1; i++) ++ { ++ tst1 = fabsf(h[i + ldh]) + fabsf(h[i+1 + ldh]); ++ if (h[i+1] <= ulp*tst1) ++ { ++ h[i+1] = 0.0f; ++ } ++ } ++ // 100 ++ ++ // Compute the (kev+1)-st column of (V*Q) and ++ // temporarily store the result in WORKD(N+1:2*N). ++ // This is not necessary if h(kev+1,1) = 0. ++ ++ if (h[*kev] > 0.0f) ++ { ++ sgemv_("N", &n, &kplusp, &dbl1, v, &ldv, &q[ldq*(*kev)], &int1, &dbl0, &workd[n], &int1); ++ } ++ ++ // Compute column 1 to kev of (V*Q) in backward order ++ // taking advantage that Q is an upper triangular matrix ++ // with lower bandwidth np. ++ // Place results in v(:,kplusp-kev:kplusp) temporarily. ++ ++ for (i = 0; i < *kev; i++) ++ { ++ tmp_int = kplusp - i; ++ sgemv_("N", &n, &tmp_int, &dbl1, v, &ldv, &q[ldq*(*kev-i-1)], &int1, &dbl0, workd, &int1); ++ scopy_(&n, workd, &int1, &v[ldv*(kplusp-i-1)], &int1); ++ } ++ // 130 ++ ++ // Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). ++ ++ for (i = 0; i < *kev; i++) ++ { ++ scopy_(&n, &v[ldv*(np+i)], &int1, &v[ldv*i], &int1); ++ } ++ // 140 ++ ++ if (h[*kev] > 0.0f) ++ { ++ scopy_(&n, &workd[n], &int1, &v[ldv*(*kev)], &int1); ++ } ++ ++ // Update the residual vector: ++ // r <- sigmak*r + betak*v(:,kev+1) ++ // where ++ // sigmak = (e_{kev+p}'*Q)*e_{kev} ++ // betak = e_{kev+1}'*H*e_{kev} ++ ++ sscal_(&n, &q[kplusp-1 + (*kev-1)*ldq], resid, &int1); ++ if (h[*kev] > 0.0f) ++ { ++ saxpy_(&n, &h[*kev], &v[ldv*(*kev)], &int1, resid, &int1); ++ } ++ ++ return; ++} ++ ++ ++void ++ssgets(struct ARPACK_arnoldi_update_vars_s *V, int* kev, int* np, float* ritz, ++ float* bounds, float* shifts) ++{ ++ int kevd2, tmp1, tmp2, int1 = 1; ++ if (V->which == which_BE) ++ { ++ // Both ends of the spectrum are requested. ++ // Sort the eigenvalues into algebraically increasing ++ // order first then swap high end of the spectrum next ++ // to low end in appropriate locations. ++ // NOTE: when np < floor(kev/2) be careful not to swap ++ // overlapping locations. ++ ++ ssortr(which_LA, 1, *kev + *np, ritz, bounds); ++ kevd2 = *kev / 2; ++ if (*kev > 1) ++ { ++ tmp1 = (kevd2 > *np ? *np : kevd2); ++ tmp2 = (kevd2 > *np ? kevd2 : *np); ++ sswap_(&tmp1, ritz, &int1, &ritz[tmp2], &int1); ++ sswap_(&tmp1, bounds, &int1, &bounds[tmp2], &int1); ++ } ++ } else { ++ ++ // LM, SM, LA, SA case. ++ // Sort the eigenvalues of H into the desired order ++ // and apply the resulting order to BOUNDS. ++ // The eigenvalues are sorted so that the wanted part ++ // are always in the last KEV locations. ++ ++ ssortr(V->which, 1, *kev + *np, ritz, bounds); ++ } ++ ++ if ((V->shift == 1) && (*np > 0)) ++ { ++ ++ // Sort the unwanted Ritz values used as shifts so that ++ // the ones with largest Ritz estimates are first. ++ // This will tend to minimize the effects of the ++ // forward instability of the iteration when the shifts ++ // are applied in subroutine dsapps. ++ ++ ssortr(which_SM, 1, *np, bounds, ritz); ++ scopy_(np, ritz, &int1, shifts, &int1); ++ } ++} ++ ++ ++void ++sgetv0(struct ARPACK_arnoldi_update_vars_s *V, int initv, int n, int j, ++ float* v, int ldv, float* resid, float* rnorm, int* ipntr, float* workd) ++{ ++ int jj, int1 = 1; ++ const float sq2o2 = sqrtf(2.0f) / 2.0f; ++ float dbl1 = 1.0f, dbl0 = 0.0f, dblm1 = -1.0f; ++ ++ if (V->ido == ido_FIRST) ++ { ++ V->info = 0; ++ V->getv0_iter = 0; ++ V->getv0_first = 0; ++ V->getv0_orth = 0; ++ ++ // Possibly generate a random starting vector in RESID ++ // Skip if this the return of ido_RANDOM. ++ ++ if (!(initv)) ++ { ++ // Request a random vector from the user into resid ++ V->ido = ido_RANDOM; ++ return; ++ } else { ++ V->ido = ido_RANDOM; ++ } ++ } ++ ++ // Back from random vector generation ++ if (V->ido == ido_RANDOM) ++ { ++ // Force the starting vector into the range of OP to handle ++ // the generalized problem when B is possibly (singular). ++ ++ if (V->getv0_itry == 1) ++ { ++ ipntr[0] = 0; ++ ipntr[1] = n; ++ scopy_(&n, resid, &int1, workd, &int1); ++ V->ido = ido_RANDOM_OPX; ++ return; ++ } else if ((V->getv0_itry > 1) && (V->bmat == 1)) ++ { ++ scopy_(&n, resid, &int1, &workd[n], &int1); ++ } ++ } ++ ++ // Back from computing OP*(initial-vector) ++ ++ if (V->getv0_first) { goto LINE20; } ++ ++ // Back from computing OP*(orthogonalized-vector) ++ ++ if (V->getv0_orth) { goto LINE40; } ++ ++ // Starting vector is now in the range of OP; r = OP*r; ++ // Compute B-norm of starting vector. ++ ++ V->getv0_first = 1; ++ if (V->getv0_itry == 1) ++ { ++ scopy_(&n, &workd[n], &int1, resid, &int1); ++ } ++ if (V->bmat) ++ { ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ scopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE20: ++ ++ V->getv0_first = 0; ++ if (V->bmat) ++ { ++ V->getv0_rnorm0 = sdot_(&n, resid, &int1, workd, &int1); ++ V->getv0_rnorm0 = sqrtf(fabsf(V->getv0_rnorm0)); ++ } else { ++ V->getv0_rnorm0 = snrm2_(&n, resid, &int1); ++ } ++ *rnorm = V->getv0_rnorm0; ++ ++ // Exit if this is the very first Arnoldi step ++ ++ if (j == 0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ // Otherwise need to B-orthogonalize the starting vector against ++ // the current Arnoldi basis using Gram-Schmidt with iter. ref. ++ // This is the case where an invariant subspace is encountered ++ // in the middle of the Arnoldi factorization. ++ // ++ // s = V^{T}*B*r; r = r - V*s; ++ // ++ // Stopping criteria used for iter. ref. is discussed in ++ // Parlett's book, page 107 and in Gragg & Reichel TOMS paper. ++ ++ V->getv0_orth = 1; ++ ++LINE30: ++ ++ sgemv_("T", &n, &j, &dbl1, v, &ldv, workd, &int1, &dbl0, &workd[n], &int1); ++ sgemv_("N", &n, &j, &dblm1, v, &ldv, &workd[n], &int1, &dbl1, resid, &int1); ++ ++ // Compute the B-norm of the orthogonalized starting vector ++ ++ if (V->bmat) ++ { ++ scopy_(&n, resid, &int1, &workd[n], &int1); ++ ipntr[0] = n; ++ ipntr[1] = 0; ++ V->ido = ido_BX; ++ return; ++ } else { ++ scopy_(&n, resid, &int1, workd, &int1); ++ } ++ ++LINE40: ++ if (V->bmat) ++ { ++ *rnorm = sdot_(&n, resid, &int1, workd, &int1); ++ *rnorm = sqrtf(fabsf(*rnorm)); ++ } else { ++ *rnorm = snrm2_(&n, resid, &int1); ++ } ++ ++ // Check for further orthogonalization. ++ ++ if (*rnorm > sq2o2*V->getv0_rnorm0) ++ { ++ V->ido = ido_DONE; ++ return; ++ } ++ ++ V->getv0_iter += 1; ++ if (V->getv0_iter < 5) ++ { ++ ++ // Perform iterative refinement step ++ ++ V->getv0_rnorm0 = *rnorm; ++ goto LINE30; ++ } else { ++ ++ // Iterative refinement step "failed" ++ ++ for (jj = 0; jj < n; jj++) { resid[jj] = 0.0f; } ++ *rnorm = 0.0f; ++ V->info = -1; ++ } ++ ++ V->ido = ido_DONE; ++ ++ return; ++} ++ ++ ++void ++ssortr(const enum ARPACK_which w, const int apply, const int n, float* x1, float* x2) ++{ ++ int i, igap, j; ++ float temp; ++ ARPACK_compare_rfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortr_LM; ++ break; ++ case which_SM: ++ f = sortr_SM; ++ break; ++ case which_LA: ++ f = sortr_LA; ++ break; ++ case which_SA: ++ f = sortr_SA; ++ break; ++ default: ++ f = sortr_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(x1[j], x1[j+igap])) ++ { ++ if (j < 0) { break; } ++ temp = x1[j]; ++ x1[j] = x1[j+igap]; ++ x1[j+igap] = temp; ++ ++ if (apply) ++ { ++ temp = x2[j]; ++ x2[j] = x2[j+igap]; ++ x2[j+igap] = temp; ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++} ++ ++ ++void ++ssesrt(const enum ARPACK_which w, const int apply, const int n, float* x, int na, float* a, const int lda) ++{ ++ int i, igap, j, int1 = 1; ++ float temp; ++ ARPACK_compare_rfunc *f; ++ ++ switch (w) ++ { ++ case which_LM: ++ f = sortr_LM; ++ break; ++ case which_SM: ++ f = sortr_SM; ++ break; ++ case which_LA: ++ f = sortr_LA; ++ break; ++ case which_SA: ++ f = sortr_SA; ++ break; ++ default: ++ f = sortr_LM; ++ break; ++ } ++ ++ igap = n / 2; ++ ++ while (igap != 0) ++ { ++ j = 0; ++ for (i = igap; i < n; i++) ++ { ++ while (f(x[j], x[j + igap])) ++ { ++ if (j < 0) { break; } ++ temp = x[j]; ++ x[j] = x[j+igap]; ++ x[j+igap] = temp; ++ ++ if (apply) ++ { ++ sswap_(&na, &a[lda*j], &int1, &a[lda*(j+igap)], &int1); ++ } ++ j -= igap; ++ } ++ j = i - igap + 1; ++ } ++ igap = igap / 2; ++ } ++ // 10, 40, 70, 120 ++} ++ ++ ++void ++sstqrb(int n, float* d, float* e, float* z, float* work, int* info) ++{ ++ int int1 = 1, int0 = 0; ++ float eps2 = powf(ulp, 2.0f); ++ float safmin = unfl; ++ float safmax = (1.0f / safmin); ++ float ssfmax = sqrtf(safmax) / 3.0f; ++ float ssfmin = sqrtf(safmin) / eps2; ++ ++ int nmaxit, jtot, i, ii, j, k, l1, m = 0, tmp_int = 0, l, lsv, lend, lendsv, iscale; ++ float anorm = 0.0f, rt1 = 0.0f, rt2 = 0.0f, c = 0.0f, s = 0.0f, g = 0.0f, r = 0.0f, p = 0.0f; ++ float b, f, tst; ++ ++ *info = 0; ++ if (n == 0) { return; } ++ if (n == 1) { z[0] = 1.0f; return; } ++ ++ // Set z as the last row of identity matrix ++ for (i = 0; i < n-1; i++) { z[i] = 0.0f; } ++ z[n-1] = 1.0f; ++ ++ nmaxit = n*30; ++ jtot = 0; ++ ++ // Determine where the matrix splits and choose QL or QR iteration ++ // for each block, according to whether top or bottom diagonal ++ // element is smaller. ++ ++ // Translation Note: ++ // All indices are 1-based, since the F77 code is very complicated. ++ // Instead array indices are decremented where necessary. ++ ++ l1 = 1; ++ ++ while (jtot < nmaxit) ++ { ++ if (l1 > n) { break; } ++ ++ if (l1 > 1) { e[l1 - 2] = 0.0f; } ++ if (l1 <= n - 1) ++ { ++ for (m = l1; m <= n - 1; m++) ++ { ++ tst = fabsf(e[m - 1]); ++ if (tst == 0.0f) { break; } ++ if (tst <= (sqrtf(fabsf(d[m-1]))*sqrtf(fabsf(d[m])))*ulp) ++ { ++ e[m-1] = 0.0f; ++ break; ++ } ++ } ++ // 20 ++ } else { ++ m = n; ++ } ++ // 30 ++ ++ // m will mark the splitting point, if any. ++ l = l1; ++ lsv = l; ++ lend = m; ++ lendsv = lend; ++ l1 = m + 1; ++ ++ // Scalar block, skipping ++ if (lend == l) { continue; } ++ ++ // Scale submatrix in rows and columns L to LEND ++ tmp_int = lend - l + 1; ++ anorm = slanst_("I", &tmp_int, &d[l-1], &e[l-1]); ++ iscale = 0; ++ ++ if (anorm == 0.0f) { continue; } ++ ++ if (anorm > ssfmax) ++ { ++ iscale = 1; ++ slascl_("G", &int0, &int0, &anorm, &ssfmax, &tmp_int, &int1, &d[l-1], &n, info); ++ tmp_int -= 1; ++ slascl_("G", &int0, &int0, &anorm, &ssfmax, &tmp_int, &int1, &e[l-1], &n, info); ++ } else if (anorm < ssfmin) { ++ iscale = 2; ++ slascl_("G", &int0, &int0, &anorm, &ssfmin, &tmp_int, &int1, &d[l-1], &n, info); ++ tmp_int -= 1; ++ slascl_("G", &int0, &int0, &anorm, &ssfmin, &tmp_int, &int1, &e[l-1], &n, info); ++ } ++ // Choose between QL and QR iteration ++ ++ if (fabsf(d[lend-1]) < fabsf(d[l-1])) ++ { ++ lend = lsv; ++ l = lendsv; ++ } ++ if (lend > l) ++ { ++ // QL Iteration ++ while (1) ++ { ++ // Look for small subdiagonal element. ++ // 40 ++ if (l != lend) ++ { ++ for (m = l; m < lend; m++) ++ { ++ tst = fabsf(e[m-1]); ++ tst = tst*tst; ++ if (tst <= (eps2*fabsf(d[m - 1]))*fabsf(d[m]) + safmin) { break; } ++ if (m == lend - 1) { m = lend; break; } // No break condition ++ } ++ // 50, 60 ++ } else { ++ m = lend; ++ } ++ if (m < lend) { e[m - 1] = 0.0f; } ++ ++ p = d[l - 1]; ++ if (m == l) ++ { ++ // 80 ++ // Eigenvalue found ++ d[l - 1] = p; ++ l += 1; ++ if (l <= lend) { continue; } // Top of QL iteration ++ break; // go to 140 undo scaling ++ } ++ // If remaining matrix is 2x2, use dlaev2 to compute its eigensystem ++ if (m == l + 1) ++ { ++ slaev2_(&d[l - 1], &e[l - 1], &d[l], &rt1, &rt2, &c, &s); ++ work[l - 1] = c; ++ work[n - 1 + l - 1] = s; ++ tst = z[l]; ++ z[l] = c*tst - s*z[l-1]; ++ z[l-1] = s*tst + c*z[l-1]; ++ d[l-1] = rt1; ++ d[l] = rt2; ++ e[l-1] = 0.0f; ++ l += 2; ++ if (l <= lend) { continue; } // go to 40 ++ break; // go to 140 ++ } ++ ++ if (jtot == nmaxit) { break; } // go to 140 ++ jtot += 1; ++ ++ // Form shift ++ g = (d[l]- p) / (2.0f * e[l-1]); ++ r = hypotf(g, 1.0f); ++ g = d[m-1] - p + (e[l-1] / (g + copysignf(r, g))); ++ ++ s = 1.0f; ++ c = 1.0f; ++ p = 0.0f; ++ ++ // Inner loop ++ for (i = m - 1; i >= l; i--) ++ { ++ f = s * e[i-1]; ++ b = c * e[i-1]; ++ slartg_(&g, &f, &c, &s, &r); ++ if (i != m - 1) { e[i] = r; } ++ g = d[i] - p; ++ r = (d[i-1] - g)*s + 2.0f*c*b; ++ p = s*r; ++ d[i] = g + p; ++ g = c*r - b; ++ work[i-1] = c; ++ work[n-1+i-1] = -s; ++ } ++ // 70 ++ tmp_int = m - l + 1; ++ slasr_("R", "V", "B", &int1, &tmp_int, &work[l-1], &work[n-1+l-1], &z[l-1], &int1); ++ ++ d[l-1] = d[l-1] - p; ++ e[l-1] = g; ++ ++ } ++ } else { ++ // QR Iteration ++ ++ // Look for small subdiagonal element. ++ while (1) ++ { ++ if (l != lend) ++ { ++ for (m = l; m > lend; m--) ++ { ++ tst = fabsf(e[m-2]); ++ tst = tst*tst; ++ if (tst <= (eps2*fabsf(d[m-1]))*fabsf(d[m-2]) + safmin) { break; } ++ if (m == lend+1) { m = lend; break; } // No break ++ } ++ } else { ++ m = lend; ++ } ++ // 100, 110 ++ if (m > lend) { e[m-2] = 0.0f; } ++ p = d[l-1]; ++ if (m == l) ++ { ++ // 130 ++ // Eigenvalue found ++ d[l-1] = p; ++ l -= 1; ++ if (l >= lend) { continue; } // Top of QR iteration ++ break; // go to 140 undo scaling ++ } ++ // If remaining matrix is 2x2, use dlaev2 to compute its eigensystem ++ if (m == l - 1) ++ { ++ slaev2_(&d[l-2], &e[l-2], &d[l-1], &rt1, &rt2, &c, &s); ++ tst = z[l-1]; ++ z[l-1] = c*tst - s*z[l-2]; ++ z[l-2] = s*tst + c*z[l-2]; ++ d[l-2] = rt1; ++ d[l-1] = rt2; ++ e[l-2] = 0.0f; ++ l -= 2; ++ ++ if (l >= lend) { continue; } // Top of QR iteration ++ break; // go to 140 undo scaling ++ } ++ ++ if (jtot == nmaxit) { break; } // go to 140 ++ jtot += 1; ++ ++ // Form the shift ++ g = (d[l-2] - p) / (2.0*e[l-2]); ++ r = hypotf(g, 1.0f); ++ g = d[m-1] - p + (e[l-2] / (g + copysignf(r, g))); ++ ++ s = 1.0f; ++ c = 1.0f; ++ p = 0.0f; ++ ++ // Inner loop ++ for (i = m; i < l; i++) ++ { ++ f = s * e[i-1]; ++ b = c * e[i-1]; ++ slartg_(&g, &f, &c, &s, &r); ++ if (i != m) { e[i-2] = r; } ++ g = d[i-1] - p; ++ r = (d[i] - g)*s + 2.0f*c*b; ++ p = s*r; ++ d[i-1] = g + p; ++ g = c*r - b; ++ ++ // Save rotations ++ work[i-1] = c; ++ work[n-1+i-1] = s; ++ } ++ // 120 ++ // Apply saved rotations. ++ tmp_int = l - m + 1; ++ slasr_("R", "V", "F", &int1, &tmp_int, &work[m-1], &work[n-1+m-1], &z[m-1], &int1); ++ ++ d[l-1] = d[l-1] - p; ++ e[l - 2] = g; ++ ++ } ++ } ++ // 140 Still in the outer while loop; it breaks at the top ++ ++ // Undo scaling if necessary ++ tmp_int = lendsv-lsv+1; ++ if (iscale == 1) ++ { ++ ++ slascl_("G", &int0, &int0, &ssfmax, &anorm, &tmp_int, &int1, &d[lsv-1], &n, info); ++ tmp_int -= 1; ++ slascl_("G", &int0, &int0, &ssfmax, &anorm, &tmp_int, &int1, &e[lsv-1], &n, info); ++ ++ } else if (iscale == 2) { ++ ++ slascl_("G", &int0, &int0, &ssfmin, &anorm, &tmp_int, &int1, &d[lsv-1], &n, info); ++ tmp_int -= 1; ++ slascl_("G", &int0, &int0, &ssfmin, &anorm, &tmp_int, &int1, &e[lsv-1], &n, info); ++ ++ } ++ ++ // Check for no convergence to an eigenvalue after a total of n*maxit iterations ++ if (jtot >= nmaxit) ++ { ++ for (i = 0; i < n-1; i++) { if (e[i] != 0.0f) { *info += 1; } } ++ return; // 150 ++ } ++ } ++ // Out of the while loop ++ ++ // Order eigenvalues and eigenvectors. ++ // Use selection sort to minimize swaps of eigenvectors. ++ for (ii = 1; ii < n; ii++) ++ { ++ i = ii - 1; ++ k = i; ++ p = d[i]; ++ ++ for (j = ii; j < n; j++) ++ { ++ if (d[j] < p) ++ { ++ k = j; ++ p = d[j]; ++ } ++ } ++ // 170 ++ if (k != i) ++ { ++ d[k] = d[i]; ++ d[i] = p; ++ p = z[k]; ++ z[k] = z[i]; ++ z[i] = p; ++ } ++ } ++ // 180 ++ ++ return; ++} ++ ++ ++int sortr_LM(const float x1, const float x2) { return (fabsf(x1) > fabsf(x2)); } ++int sortr_SM(const float x1, const float x2) { return (fabsf(x1) < fabsf(x2)); } ++int sortr_LA(const float x1, const float x2) { return (x1 > x2); } ++int sortr_SA(const float x1, const float x2) { return (x1 < x2); } +diff --git a/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.h b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.h +new file mode 100644 +index 0000000000..f7d9c8967c +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/ARPACK/_arpack_s_single.h +@@ -0,0 +1,31 @@ ++#ifndef _ARPACK_S_SINGLE_H ++#define _ARPACK_S_SINGLE_H ++ ++#include "_arpack.h" ++ ++// BLAS Routines used ++void saxpy_(int* n, float* alpha, float* x, int* incx, float* y, int* incy); ++void scopy_(int* n, float* x, int* incx, float* y, int* incy); ++float sdot_(int* n, float* x, int* incx, float* y, int* incy); ++void sgemv_(char* trans, int* m, int* n, float* alpha, float* a, int* lda, float* x, int* incx, float* beta, float* y, int* incy); ++void sger_(int* m, int* n, float* alpha, float* x, int* incx, float* y, int* incy, float* a, int* lda); ++float snrm2_(int* n, float* x, int* incx); ++void srot_(int* n, float* sx, int* incx, float* sy, int* incy, float* c, float* s); ++void sscal_(int* n, float* alpha, float* x, int* incx); ++void sswap_(int* n, float* x, int* incx, float* y, int* incy); ++void strmm_(char* side, char* uplo, char* transa, char* diag, int* m, int* n, float* alpha, float* a, int* lda, float* b, int* ldb); ++ ++// LAPACK Routines used ++void sgeqr2_(int* m, int* n, float* a, int* lda, float* tau, float* work, int* info); ++void slacpy_(char* uplo, int* m, int* n, float* a, int* lda, float* b, int* ldb); ++void slaev2_(float* a, float* b, float* c, float* rt1, float* rt2, float* cs1, float* sn1); ++float slanst_(char* norm, int* n, float* d, float* e); ++void slartg_(float* f, float* g, float* c, float* s, float* r); ++void slartgp_(float* f, float* g, float* c, float* s, float* r); ++void slascl_(char* mtype, int* kl, int* ku, float* cfrom, float* cto, int* m, int* n, float* a, int* lda, int* info); ++void slasr_(char* side, char* pivot, char* direct, int* m, int* n, float* c, float* s, float* a, int* lda); ++void slaset_(char* uplo, int* m, int* n, float* alpha, float* beta, float* a, int* lda); ++void sorm2r_(char* side, char* trans, int* m, int* n, int* k, float* a, int* lda, float* tau, float* c, int* ldc, float* work, int* info); ++void ssteqr_(char* compz, int* n, float* d, float* e, float* z, int* ldz, float* work, int* info); ++ ++#endif +diff --git a/scipy/sparse/linalg/_eigen/arpack/README b/scipy/sparse/linalg/_eigen/arpack/README +deleted file mode 100644 +index 6a729f4752..0000000000 +--- a/scipy/sparse/linalg/_eigen/arpack/README ++++ /dev/null +@@ -1,91 +0,0 @@ +-This is the ARPACK package from +-http://www.caam.rice.edu/software/ARPACK/ +- +-Specifically the files are from +-http://www.caam.rice.edu/software/ARPACK/SRC/arpack96.tar.gz +-with the patch +-http://www.caam.rice.edu/software/ARPACK/SRC/patch.tar.gz +- +-The ARPACK README is at +-http://www.caam.rice.edu/software/ARPACK/SRC/readme.arpack +- +---- +- +-ARPACK is a collection of Fortran77 subroutines designed to solve large +-scale eigenvalue problems. +- +-The package is designed to compute a few eigenvalues and corresponding +-eigenvectors of a general n by n matrix A. It is most appropriate for large +-sparse or structured matrices A where structured means that a matrix-vector +-product w <- Av requires order n rather than the usual order n**2 floating +-point operations. This software is based upon an algorithmic variant of the +-Arnoldi process called the Implicitly Restarted Arnoldi Method (IRAM). When +-the matrix A is symmetric it reduces to a variant of the Lanczos process +-called the Implicitly Restarted Lanczos Method (IRLM). These variants may be +-viewed as a synthesis of the Arnoldi/Lanczos process with the Implicitly +-Shifted QR technique that is suitable for large scale problems. For many +-standard problems, a matrix factorization is not required. Only the action +-of the matrix on a vector is needed. ARPACK software is capable of solving +-large scale symmetric, nonsymmetric, and generalized eigenproblems from +-significant application areas. The software is designed to compute a few (k) +-eigenvalues with user specified features such as those of largest real part +-or largest magnitude. Storage requirements are on the order of n*k locations. +-No auxiliary storage is required. A set of Schur basis vectors for the desired +-k-dimensional eigen-space is computed which is numerically orthogonal to working +-precision. Numerically accurate eigenvectors are available on request. +- +-Important Features: +- +- o Reverse Communication Interface. +- o Single and Double Precision Real Arithmetic Versions for Symmetric, +- Non-symmetric, Standard or Generalized Problems. +- o Single and Double Precision Complex Arithmetic Versions for Standard +- or Generalized Problems. +- o Routines for Banded Matrices - Standard or Generalized Problems. +- o Routines for The Singular Value Decomposition. +- o Example driver routines that may be used as templates to implement +- numerous Shift-Invert strategies for all problem types, data types +- and precision. +- +---- +- +-The ARPACK license is the BSD 3-clause license ("New BSD License") +-http://www.caam.rice.edu/software/ARPACK/RiceBSD.txt +- +---- +- +-BSD Software License +- +-Pertains to ARPACK and P_ARPACK +- +-Copyright (c) 1996-2008 Rice University. +-Developed by D.C. Sorensen, R.B. Lehoucq, C. Yang, and K. Maschhoff. +-All rights reserved. +- +-Redistribution and use in source and binary forms, with or without +-modification, are permitted provided that the following conditions are +-met: +- +-- Redistributions of source code must retain the above copyright +- notice, this list of conditions and the following disclaimer. +- +-- Redistributions in binary form must reproduce the above copyright +- notice, this list of conditions and the following disclaimer listed +- in this license in the documentation and/or other materials +- provided with the distribution. +- +-- Neither the name of the copyright holders nor the names of its +- contributors may be used to endorse or promote products derived from +- this software without specific prior written permission. +- +-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +diff --git a/scipy/sparse/linalg/_eigen/arpack/_arpackmodule.c b/scipy/sparse/linalg/_eigen/arpack/_arpackmodule.c +new file mode 100644 +index 0000000000..10b448cbb2 +--- /dev/null ++++ b/scipy/sparse/linalg/_eigen/arpack/_arpackmodule.c +@@ -0,0 +1,1078 @@ ++/* ++ * Python bindings for SciPy usage ++ */ ++ ++#define PY_SSIZE_T_CLEAN ++#include "Python.h" ++#include "numpy/arrayobject.h" ++#include "ARPACK/_arpack.h" ++ ++#if defined(_MSC_VER) ++ #define ARPACK_cplx(real, imag) ((_Dcomplex){real, imag}) ++ #define ARPACK_cplxf(real, imag) ((_Fcomplex){real, imag}) ++#else ++ #define ARPACK_cplx(real, imag) ((real) + (imag)*I) ++ #define ARPACK_cplxf(real, imag) ((real) + (imag)*I) ++#endif ++ ++#define PYERR(errobj,message) {PyErr_SetString(errobj,message); return NULL;} ++static PyObject* arpack_error; ++ ++// The following macros are used to define the field names in the ARPACK struct. ++#define STRUCT_INEXACT_FIELD_NAMES X(tol) X(getv0_rnorm0) X(aitr_betaj) X(aitr_rnorm1) X(aitr_wnorm) X(aup2_rnorm) ++#define STRUCT_INT_FIELD_NAMES X(ido) X(which) X(bmat) X(info) X(iter) X(maxiter) X(mode) \ ++ X(n) X(nconv) X(ncv) X(nev) X(np) \ ++ X(shift) X(getv0_first) X(getv0_iter) X(getv0_itry) X(getv0_orth) \ ++ X(aitr_iter) X(aitr_j) X(aitr_orth1) X(aitr_orth2) X(aitr_restart) \ ++ X(aitr_step3) X(aitr_step4) X(aitr_ierr) X(aup2_initv) X(aup2_iter) \ ++ X(aup2_getv0) X(aup2_cnorm) X(aup2_kplusp) X(aup2_nev0) X(aup2_np0) \ ++ X(aup2_numcnv) X(aup2_update) X(aup2_ushift) ++#define STRUCT_FIELD_NAMES STRUCT_INT_FIELD_NAMES STRUCT_INEXACT_FIELD_NAMES ++ ++ ++static PyObject* ++snaupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_v=NULL; ++ PyArrayObject* ap_ipntr=NULL; ++ PyArrayObject* ap_workd=NULL; ++ PyArrayObject* ap_workl=NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = PyArray_DATA(ap_ipntr); ++ float* resid = PyArray_DATA(ap_resid); ++ float* v = PyArray_DATA(ap_v); ++ float* workd = PyArray_DATA(ap_workd); ++ float* workl = PyArray_DATA(ap_workl); ++ ++ // Map the input dict to the ARPACK structure ++ ++ // Parse the dictionary, if the field is not found, raise an error. ++ // Do it separately for floats and ints. ++ ++ // Declare and Initialize the ARPACK struct that will be populated from dict with zeros ++ struct ARPACK_arnoldi_update_vars_s Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (float)PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ // Call ARPACK function ++ ARPACK_snaupd(&Vars, resid, v, Vars.n, ipntr, workd, workl); ++ ++ // Unpack the struct back to the dictionary ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyFloat_FromDouble((double)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyLong_FromLong((long)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++dnaupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_v=NULL; ++ PyArrayObject* ap_ipntr=NULL; ++ PyArrayObject* ap_workd=NULL; ++ PyArrayObject* ap_workl=NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ double* resid = (double*)PyArray_DATA(ap_resid); ++ double* v = (double*)PyArray_DATA(ap_v); ++ double* workd = (double*)PyArray_DATA(ap_workd); ++ double* workl = (double*)PyArray_DATA(ap_workl); ++ ++ // Parse the dictionary, if the field is not found, raise an error. ++ // Do it separately for floats and ints. ++ ++ // Declare and Initialize the ARPACK struct that will be populated from dict with zeros ++ struct ARPACK_arnoldi_update_vars_d Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ // Call ARPACK function ++ ARPACK_dnaupd(&Vars, resid, v, Vars.n, ipntr, workd, workl); ++ ++ // Unpack the struct back to the dictionary ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyFloat_FromDouble(Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyLong_FromLong((long)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++cnaupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_v=NULL; ++ PyArrayObject* ap_ipntr=NULL; ++ PyArrayObject* ap_workd=NULL; ++ PyArrayObject* ap_workl=NULL; ++ PyArrayObject* ap_rwork=NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl, // O! ++ &PyArray_Type, (PyObject **)&ap_rwork // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ ARPACK_CPLXF_TYPE* resid = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_resid); ++ ARPACK_CPLXF_TYPE* v = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_v); ++ ARPACK_CPLXF_TYPE* workd = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_workd); ++ ARPACK_CPLXF_TYPE* workl = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_workl); ++ float* rwork = (float*)PyArray_DATA(ap_rwork); ++ ++ // Map the input dict to the ARPACK structure ++ ++ // Parse the dictionary, if the field is not found, raise an error. ++ // Do it separately for floats and ints. ++ ++ // Declare and Initialize the ARPACK struct that will be populated from dict with zeros ++ struct ARPACK_arnoldi_update_vars_s Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (float)PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ // Call ARPACK function ++ ARPACK_cnaupd(&Vars, resid, v, Vars.n, ipntr, workd, workl, rwork); ++ ++ // Unpack the struct back to the dictionary ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyFloat_FromDouble((double)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyLong_FromLong((long)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++znaupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_v=NULL; ++ PyArrayObject* ap_ipntr=NULL; ++ PyArrayObject* ap_workd=NULL; ++ PyArrayObject* ap_workl=NULL; ++ PyArrayObject* ap_rwork=NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl, // O! ++ &PyArray_Type, (PyObject **)&ap_rwork // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ ARPACK_CPLX_TYPE* resid = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_resid); ++ ARPACK_CPLX_TYPE* v = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_v); ++ ARPACK_CPLX_TYPE* workd = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_workd); ++ ARPACK_CPLX_TYPE* workl = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_workl); ++ double* rwork = (double*)PyArray_DATA(ap_rwork); ++ ++ // Parse the dictionary, if the field is not found, raise an error. ++ // Do it separately for floats and ints. ++ ++ // Declare and Initialize the ARPACK struct that will be populated from dict with zeros ++ struct ARPACK_arnoldi_update_vars_d Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ // Call ARPACK function ++ ARPACK_znaupd(&Vars, resid, v, Vars.n, ipntr, workd, workl, rwork); ++ ++ // Unpack the struct back to the dictionary ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyFloat_FromDouble(Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyLong_FromLong((long)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++sneupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ ++ PyObject* input_dict = NULL; ++ int want_ev = 0, howmny = 0, ldv = 0, ldz = 0; ++ PyArrayObject* ap_select = NULL; ++ float sigmar = 0.0; ++ float sigmai = 0.0; ++ PyArrayObject* ap_dr = NULL; ++ PyArrayObject* ap_di = NULL; ++ PyArrayObject* ap_v = NULL; ++ PyArrayObject* ap_z = NULL; ++ PyArrayObject* ap_workev = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_ipntr = NULL; ++ PyArrayObject* ap_workd = NULL; ++ PyArrayObject* ap_workl = NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!iiO!O!O!O!ffO!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &want_ev, // i ++ &howmny, // i ++ &PyArray_Type, (PyObject **)&ap_select, // O! ++ &PyArray_Type, (PyObject **)&ap_dr, // O! ++ &PyArray_Type, (PyObject **)&ap_di, // O! ++ &PyArray_Type, (PyObject **)&ap_z, // O! ++ &sigmar, // f ++ &sigmai, // f ++ &PyArray_Type, (PyObject **)&ap_workev, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ int* select = (int*)PyArray_DATA(ap_select); ++ float* dr = (float*)PyArray_DATA(ap_dr); ++ float* di = (float*)PyArray_DATA(ap_di); ++ float* workev = (float*)PyArray_DATA(ap_workev); ++ float* z = (float*)PyArray_DATA(ap_z); ++ float* resid = (float*)PyArray_DATA(ap_resid); ++ float* v = (float*)PyArray_DATA(ap_v); ++ float* workd = (float*)PyArray_DATA(ap_workd); ++ float* workl = (float*)PyArray_DATA(ap_workl); ++ ldv = (int)PyArray_DIMS(ap_v)[0]; ++ ldz = (int)PyArray_DIMS(ap_z)[0]; ++ ++ struct ARPACK_arnoldi_update_vars_s Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (float)PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ ++ ARPACK_sneupd(&Vars, want_ev, howmny, select, dr, di, z, ldz, sigmar, sigmai, workev, resid, v, ldv, ipntr, workd, workl); ++ ++ Py_RETURN_NONE; ++ ++} ++ ++static PyObject* ++dneupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ ++ PyObject* input_dict = NULL; ++ int want_ev = 0, howmny = 0, ldv = 0, ldz = 0; ++ PyArrayObject* ap_select = NULL; ++ double sigmar = 0.0; ++ double sigmai = 0.0; ++ PyArrayObject* ap_dr = NULL; ++ PyArrayObject* ap_di = NULL; ++ PyArrayObject* ap_v = NULL; ++ PyArrayObject* ap_z = NULL; ++ PyArrayObject* ap_workev = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_ipntr = NULL; ++ PyArrayObject* ap_workd = NULL; ++ PyArrayObject* ap_workl = NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!iiO!O!O!O!ddO!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &want_ev, // i ++ &howmny, // i ++ &PyArray_Type, (PyObject **)&ap_select, // O! ++ &PyArray_Type, (PyObject **)&ap_dr, // O! ++ &PyArray_Type, (PyObject **)&ap_di, // O! ++ &PyArray_Type, (PyObject **)&ap_z, // O! ++ &sigmar, // d ++ &sigmai, // d ++ &PyArray_Type, (PyObject **)&ap_workev, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ int* select = (int*)PyArray_DATA(ap_select); ++ double* dr = (double*)PyArray_DATA(ap_dr); ++ double* di = (double*)PyArray_DATA(ap_di); ++ double* workev = (double*)PyArray_DATA(ap_workev); ++ double* z = (double*)PyArray_DATA(ap_z); ++ double* resid = (double*)PyArray_DATA(ap_resid); ++ double* v = (double*)PyArray_DATA(ap_v); ++ double* workd = (double*)PyArray_DATA(ap_workd); ++ double* workl = (double*)PyArray_DATA(ap_workl); ++ ldv = (int)PyArray_DIMS(ap_v)[0]; ++ ldz = (int)PyArray_DIMS(ap_z)[0]; ++ ++ struct ARPACK_arnoldi_update_vars_d Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ ARPACK_dneupd(&Vars, want_ev, howmny, select, dr, di, z, ldz, sigmar, sigmai, workev, resid, v, ldv, ipntr, workd, workl); ++ ++ Py_RETURN_NONE; ++ ++} ++ ++ ++static PyObject* ++cneupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ int want_ev = 0, howmny = 0, ldv = 0, ldz = 0; ++ PyArrayObject* ap_select = NULL; ++ Py_complex sigma = { .real = 0.0, .imag = 0.0 }; ++ PyArrayObject* ap_d = NULL; ++ PyArrayObject* ap_v = NULL; ++ PyArrayObject* ap_z = NULL; ++ PyArrayObject* ap_workev = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_ipntr = NULL; ++ PyArrayObject* ap_workd = NULL; ++ PyArrayObject* ap_workl = NULL; ++ PyArrayObject* ap_rwork = NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!iiO!O!O!DO!O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &want_ev, // i ++ &howmny, // i ++ &PyArray_Type, (PyObject **)&ap_select, // O! ++ &PyArray_Type, (PyObject **)&ap_d, // O! ++ &PyArray_Type, (PyObject **)&ap_z, // O! ++ &sigma, // D ++ &PyArray_Type, (PyObject **)&ap_workev, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl, // O! ++ &PyArray_Type, (PyObject **)&ap_rwork // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ int* select = (int*)PyArray_DATA(ap_select); ++ ARPACK_CPLXF_TYPE* d = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_d); ++ ARPACK_CPLXF_TYPE* workev = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_workev); ++ ARPACK_CPLXF_TYPE* z = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_z); ++ ARPACK_CPLXF_TYPE* resid = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_resid); ++ ARPACK_CPLXF_TYPE* v = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_v); ++ ARPACK_CPLXF_TYPE* workd = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_workd); ++ ARPACK_CPLXF_TYPE* workl = (ARPACK_CPLXF_TYPE*)PyArray_DATA(ap_workl); ++ float* rwork = PyArray_DATA(ap_rwork); ++ ldv = (int)PyArray_DIMS(ap_v)[0]; ++ ldz = (int)PyArray_DIMS(ap_z)[0]; ++ ARPACK_CPLXF_TYPE sigmaC = ARPACK_cplxf((float)sigma.real, (float)sigma.imag); ++ struct ARPACK_arnoldi_update_vars_s Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (float)PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ ARPACK_cneupd(&Vars, want_ev, howmny, select, d, z, ldz, sigmaC, workev, resid, v, ldv, ipntr, workd, workl, rwork); ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++zneupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ int want_ev = 0, howmny = 0, ldv = 0, ldz = 0; ++ PyArrayObject* ap_select = NULL; ++ Py_complex sigma = { .real = 0.0, .imag = 0.0 }; ++ PyArrayObject* ap_d = NULL; ++ PyArrayObject* ap_v = NULL; ++ PyArrayObject* ap_z = NULL; ++ PyArrayObject* ap_workev = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_ipntr = NULL; ++ PyArrayObject* ap_workd = NULL; ++ PyArrayObject* ap_workl = NULL; ++ PyArrayObject* ap_rwork = NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!iiO!O!O!DO!O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &want_ev, // i ++ &howmny, // i ++ &PyArray_Type, (PyObject **)&ap_select, // O! ++ &PyArray_Type, (PyObject **)&ap_d, // O! ++ &PyArray_Type, (PyObject **)&ap_z, // O! ++ &sigma, // D ++ &PyArray_Type, (PyObject **)&ap_workev, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl, // O! ++ &PyArray_Type, (PyObject **)&ap_rwork // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ int* select = (int*)PyArray_DATA(ap_select); ++ ARPACK_CPLX_TYPE* d = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_d); ++ ARPACK_CPLX_TYPE* workev = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_workev); ++ ARPACK_CPLX_TYPE* z = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_z); ++ ARPACK_CPLX_TYPE* resid = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_resid); ++ ARPACK_CPLX_TYPE* v = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_v); ++ ARPACK_CPLX_TYPE* workd = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_workd); ++ ARPACK_CPLX_TYPE* workl = (ARPACK_CPLX_TYPE*)PyArray_DATA(ap_workl); ++ double* rwork = PyArray_DATA(ap_rwork); ++ ldv = (int)PyArray_DIMS(ap_v)[0]; ++ ldz = (int)PyArray_DIMS(ap_z)[0]; ++ ARPACK_CPLX_TYPE sigmaC = ARPACK_cplx(sigma.real, sigma.imag); ++ struct ARPACK_arnoldi_update_vars_d Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ ARPACK_zneupd(&Vars, want_ev, howmny, select, d, z, ldz, sigmaC, workev, resid, v, ldv, ipntr, workd, workl, rwork); ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++ssaupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_v=NULL; ++ PyArrayObject* ap_ipntr=NULL; ++ PyArrayObject* ap_workd=NULL; ++ PyArrayObject* ap_workl=NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = PyArray_DATA(ap_ipntr); ++ float* resid = PyArray_DATA(ap_resid); ++ float* v = PyArray_DATA(ap_v); ++ float* workd = PyArray_DATA(ap_workd); ++ float* workl = PyArray_DATA(ap_workl); ++ ++ // Map the input dict to the ARPACK structure ++ ++ // Parse the dictionary, if the field is not found, raise an error. ++ // Do it separately for floats and ints. ++ ++ // Declare and Initialize the ARPACK struct that will be populated from dict with zeros ++ struct ARPACK_arnoldi_update_vars_s Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (float)PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ // Call ARPACK function ++ ARPACK_ssaupd(&Vars, resid, v, Vars.n, ipntr, workd, workl); ++ ++ // Unpack the struct back to the dictionary ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyFloat_FromDouble((double)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyLong_FromLong((long)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ Py_RETURN_NONE; ++} ++ ++static PyObject* ++dsaupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_v=NULL; ++ PyArrayObject* ap_ipntr=NULL; ++ PyArrayObject* ap_workd=NULL; ++ PyArrayObject* ap_workl=NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!O!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ double* resid = (double*)PyArray_DATA(ap_resid); ++ double* v = (double*)PyArray_DATA(ap_v); ++ double* workd = (double*)PyArray_DATA(ap_workd); ++ double* workl = (double*)PyArray_DATA(ap_workl); ++ ++ // Parse the dictionary, if the field is not found, raise an error. ++ // Do it separately for floats and ints. ++ ++ // Declare and Initialize the ARPACK struct that will be populated from dict with zeros ++ struct ARPACK_arnoldi_update_vars_d Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ // Call ARPACK function ++ ARPACK_dsaupd(&Vars, resid, v, Vars.n, ipntr, workd, workl); ++ ++ // Unpack the struct back to the dictionary ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyFloat_FromDouble(Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) do { \ ++ PyObject* tmp_##name = PyLong_FromLong((long)Vars.name); \ ++ if ((!tmp_##name) || (PyDict_SetItemString(input_dict, #name, tmp_##name) < 0)) { \ ++ Py_XDECREF(tmp_##name); \ ++ PYERR(arpack_error, "Setting '" #name "' failed."); \ ++ } \ ++ Py_DECREF(tmp_##name); \ ++ } while (0); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ Py_RETURN_NONE; ++} ++ ++static PyObject* ++sseupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ int want_ev = 0, howmny = 0, ldv = 0, ldz = 0; ++ PyArrayObject* ap_select = NULL; ++ float sigma = 0.0; ++ PyArrayObject* ap_d = NULL; ++ PyArrayObject* ap_v = NULL; ++ PyArrayObject* ap_z = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_ipntr = NULL; ++ PyArrayObject* ap_workd = NULL; ++ PyArrayObject* ap_workl = NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!iiO!O!O!fO!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &want_ev, // i ++ &howmny, // i ++ &PyArray_Type, (PyObject **)&ap_select, // O! ++ &PyArray_Type, (PyObject **)&ap_d, // O! ++ &PyArray_Type, (PyObject **)&ap_z, // O! ++ &sigma, // f ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ int* select = (int*)PyArray_DATA(ap_select); ++ float* d = (float*)PyArray_DATA(ap_d); ++ float* z = (float*)PyArray_DATA(ap_z); ++ float* resid = (float*)PyArray_DATA(ap_resid); ++ float* v = (float*)PyArray_DATA(ap_v); ++ float* workd = (float*)PyArray_DATA(ap_workd); ++ float* workl = (float*)PyArray_DATA(ap_workl); ++ ldv = (int)PyArray_DIMS(ap_v)[0]; ++ ldz = (int)PyArray_DIMS(ap_z)[0]; ++ ++ struct ARPACK_arnoldi_update_vars_s Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (float)PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ ++ ARPACK_sseupd(&Vars, want_ev, howmny, select, d, z, ldz, sigma, resid, v, ldv, ipntr, workd, workl); ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static PyObject* ++dseupd_wrap(PyObject* Py_UNUSED(dummy), PyObject* args) ++{ ++ PyObject* input_dict = NULL; ++ int want_ev = 0, howmny = 0, ldv = 0, ldz = 0; ++ PyArrayObject* ap_select = NULL; ++ double sigma = 0.0; ++ PyArrayObject* ap_d = NULL; ++ PyArrayObject* ap_v = NULL; ++ PyArrayObject* ap_z = NULL; ++ PyArrayObject* ap_resid = NULL; ++ PyArrayObject* ap_ipntr = NULL; ++ PyArrayObject* ap_workd = NULL; ++ PyArrayObject* ap_workl = NULL; ++ ++ // Process input arguments ++ if (!PyArg_ParseTuple(args, "O!iiO!O!O!dO!O!O!O!O!", ++ &PyDict_Type, (PyObject **)&input_dict, // O! ++ &want_ev, // i ++ &howmny, // i ++ &PyArray_Type, (PyObject **)&ap_select, // O! ++ &PyArray_Type, (PyObject **)&ap_d, // O! ++ &PyArray_Type, (PyObject **)&ap_z, // O! ++ &sigma, // d ++ &PyArray_Type, (PyObject **)&ap_resid, // O! ++ &PyArray_Type, (PyObject **)&ap_v, // O! ++ &PyArray_Type, (PyObject **)&ap_ipntr, // O! ++ &PyArray_Type, (PyObject **)&ap_workd, // O! ++ &PyArray_Type, (PyObject **)&ap_workl // O! ++ ) ++ ) ++ { ++ return NULL; ++ } ++ ++ int* ipntr = (int*)PyArray_DATA(ap_ipntr); ++ int* select = (int*)PyArray_DATA(ap_select); ++ double* d = (double*)PyArray_DATA(ap_d); ++ double* z = (double*)PyArray_DATA(ap_z); ++ double* resid = (double*)PyArray_DATA(ap_resid); ++ double* v = (double*)PyArray_DATA(ap_v); ++ double* workd = (double*)PyArray_DATA(ap_workd); ++ double* workl = (double*)PyArray_DATA(ap_workl); ++ ldv = (int)PyArray_DIMS(ap_v)[0]; ++ ldz = (int)PyArray_DIMS(ap_z)[0]; ++ ++ struct ARPACK_arnoldi_update_vars_d Vars = {0}; ++ ++ #define X(name) Vars.name = 0; ++ STRUCT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = PyFloat_AsDouble(name##_obj); ++ STRUCT_INEXACT_FIELD_NAMES ++ #undef X ++ ++ #define X(name) \ ++ PyObject* name##_obj = PyDict_GetItemString(input_dict, #name); \ ++ if (!name##_obj) { PYERR(arpack_error, #name " not found in the dictionary."); } \ ++ Vars.name = (int)PyLong_AsLong(name##_obj); ++ STRUCT_INT_FIELD_NAMES ++ #undef X ++ ++ ARPACK_dseupd(&Vars, want_ev, howmny, select, d, z, ldz, sigma, resid, v, ldv, ipntr, workd, workl); ++ ++ Py_RETURN_NONE; ++} ++ ++ ++static char doc_snaupd[] = (""); ++static char doc_dnaupd[] = (""); ++static char doc_cnaupd[] = (""); ++static char doc_znaupd[] = (""); ++static char doc_sneupd[] = (""); ++static char doc_dneupd[] = (""); ++static char doc_cneupd[] = (""); ++static char doc_zneupd[] = (""); ++static char doc_ssaupd[] = (""); ++static char doc_dsaupd[] = (""); ++static char doc_sseupd[] = (""); ++static char doc_dseupd[] = (""); ++ ++ ++// Sentinel terminated method list. ++static struct ++PyMethodDef arpacklib_module_methods[] = { ++ {"snaupd_wrap", snaupd_wrap, METH_VARARGS, doc_snaupd}, ++ {"dnaupd_wrap", dnaupd_wrap, METH_VARARGS, doc_dnaupd}, ++ {"cnaupd_wrap", cnaupd_wrap, METH_VARARGS, doc_cnaupd}, ++ {"znaupd_wrap", znaupd_wrap, METH_VARARGS, doc_znaupd}, ++ {"sneupd_wrap", sneupd_wrap, METH_VARARGS, doc_sneupd}, ++ {"dneupd_wrap", dneupd_wrap, METH_VARARGS, doc_dneupd}, ++ {"cneupd_wrap", cneupd_wrap, METH_VARARGS, doc_cneupd}, ++ {"zneupd_wrap", zneupd_wrap, METH_VARARGS, doc_zneupd}, ++ {"ssaupd_wrap", ssaupd_wrap, METH_VARARGS, doc_ssaupd}, ++ {"dsaupd_wrap", dsaupd_wrap, METH_VARARGS, doc_dsaupd}, ++ {"sseupd_wrap", sseupd_wrap, METH_VARARGS, doc_sseupd}, ++ {"dseupd_wrap", dseupd_wrap, METH_VARARGS, doc_dseupd}, ++ {NULL, NULL, 0, NULL} ++}; ++ ++ ++static struct PyModuleDef_Slot arpacklib_module_slots[] = { ++#if PY_VERSION_HEX >= 0x030c00f0 // Python 3.12+ ++ // signal that this module can be imported in isolated subinterpreters ++ {Py_mod_multiple_interpreters, Py_MOD_PER_INTERPRETER_GIL_SUPPORTED}, ++#endif ++#if PY_VERSION_HEX >= 0x030d00f0 // Python 3.13+ ++ // signal that this module supports running without an active GIL ++ {Py_mod_gil, Py_MOD_GIL_NOT_USED}, ++#endif ++ {0, NULL}, ++}; ++ ++ ++static struct ++PyModuleDef moduledef = { ++ .m_base = PyModuleDef_HEAD_INIT, ++ .m_name = "_arpacklib", ++ .m_size = 0, ++ .m_methods = arpacklib_module_methods, ++ .m_slots = arpacklib_module_slots, ++}; ++ ++ ++PyMODINIT_FUNC ++PyInit__arpacklib(void) ++{ ++ import_array(); ++ return PyModuleDef_Init(&moduledef); ++} ++ ++ ++#undef STRUCT_FIELD_NAMES ++#undef STRUCT_INT_FIELD_NAMES ++#undef STRUCT_INEXACT_FIELD_NAMES +diff --git a/scipy/sparse/linalg/_eigen/arpack/arpack.py b/scipy/sparse/linalg/_eigen/arpack/arpack.py +index f678deabe3..a5927fd847 100644 +--- a/scipy/sparse/linalg/_eigen/arpack/arpack.py ++++ b/scipy/sparse/linalg/_eigen/arpack/arpack.py +@@ -44,10 +44,8 @@ from scipy.sparse._sputils import ( + convert_pydata_sparse_to_scipy, isdense, is_pydata_spmatrix, + ) + from scipy.sparse.linalg import gmres, splu +-from scipy._lib._util import _aligned_zeros +-from scipy._lib._threadsafety import ReentrancyLock +-from . import _arpack +-arpack_int = _arpack.timing.nbx.dtype ++ ++from . import _arpacklib + + __docformat__ = "restructuredtext en" + +@@ -270,6 +268,13 @@ _SEUPD_WHICH = ['LM', 'SM', 'LA', 'SA', 'BE'] + # accepted values of parameter WHICH in _NAUPD + _NEUPD_WHICH = ['LM', 'SM', 'LR', 'SR', 'LI', 'SI'] + ++# The enum values for the parameter WHICH in _NAUPD and _SEUPD ++WHICH_DICT = { ++ 'LM': 0, 'SM': 1, 'LR': 2, 'SR': 3, 'LI': 4, 'SI': 5, 'LA': 6, 'SA': 7, 'BE': 8 ++} ++ ++# The enum values for the parameter HOWMNY in _NEUPD and _SEUPD ++HOWMNY_DICT = {'A': 0, 'P': 1, 'S': 2} + + class ArpackError(RuntimeError): + """ +@@ -313,8 +318,8 @@ def choose_ncv(k): + + + class _ArpackParams: +- def __init__(self, n, k, tp, mode=1, sigma=None, +- ncv=None, v0=None, maxiter=None, which="LM", tol=0): ++ def __init__(self, n, k, tp, rng, mode=1, sigma=None, ncv=None, v0=None, ++ maxiter=None, which="LM", tol=0): + if k <= 0: + raise ValueError(f"k must be positive, k={k}") + +@@ -332,11 +337,11 @@ class _ArpackParams: + + if v0 is not None: + # ARPACK overwrites its initial resid, make a copy +- self.resid = np.array(v0, copy=True) ++ self.resid = np.array(v0, copy=True, dtype=tp) + info = 1 + else: + # ARPACK will use a random initial vector. +- self.resid = np.zeros(n, tp) ++ self.resid = rng.uniform(low=-1.0, high=1.0, size=[n]).astype(tp) + info = 0 + + if sigma is None: +@@ -347,35 +352,65 @@ class _ArpackParams: + + if ncv is None: + ncv = choose_ncv(k) +- ncv = min(ncv, n) +- ++ self.ncv = min(ncv, n) ++ self.n = n + self.v = np.zeros((n, ncv), tp) # holds Ritz vectors +- self.iparam = np.zeros(11, arpack_int) ++ self.which = which + + # set solver mode and parameters +- ishfts = 1 + self.mode = mode +- self.iparam[0] = ishfts +- self.iparam[2] = maxiter +- self.iparam[3] = 1 +- self.iparam[6] = mode ++ self.arpack_dict = { ++ 'tol': tol, ++ 'getv0_rnorm0': 0.0, ++ 'aitr_betaj': 0.0, ++ 'aitr_rnorm1': 0.0, ++ 'aitr_wnorm': 0.0, ++ 'aup2_rnorm': 0.0, ++ 'ido': 0, ++ 'which': WHICH_DICT[which], ++ 'bmat': 0, ++ 'info': info, ++ 'iter': 0, ++ 'maxiter': int(maxiter), ++ 'mode': mode, ++ 'n': n, ++ 'nconv': 0, ++ 'ncv': self.ncv, ++ 'nev': k, ++ 'np': 0, ++ 'shift': 1, ++ 'getv0_first': 0, ++ 'getv0_iter': 0, ++ 'getv0_itry': 0, ++ 'getv0_orth': 0, ++ 'aitr_iter': 0, ++ 'aitr_j': 0, ++ 'aitr_orth1': 0, ++ 'aitr_orth2': 0, ++ 'aitr_restart': 0, ++ 'aitr_step3': 0, ++ 'aitr_step4': 0, ++ 'aitr_ierr': 0, ++ 'aup2_initv': 0, ++ 'aup2_iter': 0, ++ 'aup2_getv0': 0, ++ 'aup2_cnorm': 0, ++ 'aup2_kplusp': 0, ++ 'aup2_nev0': 0, ++ 'aup2_np0': 0, ++ 'aup2_numcnv': 0, ++ 'aup2_update': 0, ++ 'aup2_ushift': 0, ++ } + +- self.n = n +- self.tol = tol + self.k = k +- self.maxiter = maxiter +- self.ncv = ncv +- self.which = which + self.tp = tp +- self.info = info +- + self.converged = False +- self.ido = 0 + + def _raise_no_convergence(self): + msg = "No convergence (%d iterations, %d/%d eigenvectors converged)" +- k_ok = self.iparam[4] +- num_iter = self.iparam[2] ++ k_ok = self.arpack_dict['nconv'] ++ num_iter = self.arpack_dict['iter'] + try: + ev, vec = self.extract(True) + except ArpackError as err: +@@ -383,13 +418,15 @@ class _ArpackParams: + ev = np.zeros((0,)) + vec = np.zeros((self.n, 0)) + k_ok = 0 +- raise ArpackNoConvergence(msg % (num_iter, k_ok, self.k), ev, vec) ++ raise ArpackNoConvergence(f"No convergence ({num_iter} iterations, " ++ f"{k_ok}/{self.k} eigenvectors converged)", ++ ev, vec) + + + class _SymmetricArpackParams(_ArpackParams): +- def __init__(self, n, k, tp, matvec, mode=1, M_matvec=None, +- Minv_matvec=None, sigma=None, +- ncv=None, v0=None, maxiter=None, which="LM", tol=0): ++ def __init__(self, n, k, tp, matvec, mode=1, M_matvec=None, Minv_matvec=None, ++ sigma=None, ncv=None, v0=None, maxiter=None, which="LM", tol=0, ++ rng=None): + # The following modes are supported: + # mode = 1: + # Solve the standard eigenvalue problem: +@@ -518,40 +555,37 @@ class _SymmetricArpackParams(_ArpackParams): + if k >= n: + raise ValueError(f"k must be less than ndim(A), k={k}") + +- _ArpackParams.__init__(self, n, k, tp, mode, sigma, +- ncv, v0, maxiter, which, tol) ++ self.rng = np.random.default_rng(rng) ++ _ArpackParams.__init__(self, n, k, tp, self.rng, mode, sigma, ncv, v0, ++ maxiter, which, tol) ++ ++ self.arpack_dict['bmat'] = 0 if self.bmat == 'I' else 1 + + if self.ncv > n or self.ncv <= k: + raise ValueError(f"ncv must be k= n - 1: + raise ValueError(f"k must be less than ndim(A)-1, k={k}") + +- _ArpackParams.__init__(self, n, k, tp, mode, sigma, +- ncv, v0, maxiter, which, tol) ++ self.rng = np.random.default_rng(rng) ++ _ArpackParams.__init__(self, n, k, tp, rng, mode, sigma, ncv, v0, maxiter, ++ which, tol) ++ ++ self.arpack_dict['bmat'] = 0 if self.bmat == 'I' else 1 + + if self.ncv > n or self.ncv <= k + 1: + raise ValueError(f"ncv must be k+1 +- <_cd=complex,double complex> +- interface ! in :_arpack +- subroutine saupd(ido,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in :_arpack:src/ssaupd.f +- threadsafe ! it's not really threadsafe, but we use a lock on the Python side, so keeping GIL is not needed +- integer intent(in,out):: ido +- character*1 :: bmat +- integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid) +- character*2 :: which +- integer :: nev +- <_rd>, intent(in,out) :: tol +- <_rd> dimension(n),intent(in,out) :: resid +- integer optional,check(shape(v,1)==ncv),depend(v) :: ncv=shape(v,1) +- <_rd> dimension(ldv,ncv),intent(in,out) :: v +- integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0) +- integer dimension(11),intent(in,out) :: iparam +- integer dimension(11),intent(in,out) :: ipntr +- <_rd> dimension(3 * n),depend(n),intent(inout) :: workd +- <_rd> dimension(lworkl),intent(inout) :: workl +- integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl) +- integer intent(in,out):: info +- end subroutine saupd +- +- subroutine seupd(rvec,howmny,select,d,z,ldz,sigma,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in :_arpack:src/sseupd.f +- threadsafe ! it's not really threadsafe, but we use a lock on the Python side, so keeping GIL is not needed +- logical :: rvec +- character :: howmny +- logical dimension(ncv) :: select +- <_rd> dimension(nev),intent(out),depend(nev) :: d +- <_rd> dimension(n,nev),intent(out),depend(n,nev) :: z +- integer optional,check(shape(z,0)==ldz),depend(z) :: ldz=shape(z,0) +- <_rd> :: sigma +- character :: bmat +- integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid) +- character*2 :: which +- integer :: nev +- <_rd> :: tol +- <_rd> dimension(n) :: resid +- integer optional,check(len(select)>=ncv),depend(select) :: ncv=len(select) +- <_rd> dimension(ldv,ncv),depend(ncv) :: v +- integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0) +- integer dimension(7) :: iparam +- integer dimension(11) :: ipntr +- <_rd> dimension(2 * n),depend(n) :: workd +- <_rd> dimension(lworkl) :: workl +- integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl) +- integer intent(in,out):: info +- end subroutine seupd +- +- subroutine naupd(ido,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in :_arpack:src/snaupd.f +- threadsafe ! it's not really threadsafe, but we use a lock on the Python side, so keeping GIL is not needed +- integer intent(in,out):: ido +- character*1 :: bmat +- integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid) +- character*2 :: which +- integer :: nev +- <_rd>, intent(in,out) :: tol +- <_rd> dimension(n),intent(in,out) :: resid +- integer optional,check(shape(v,1)==ncv),depend(v) :: ncv=shape(v,1) +- <_rd> dimension(ldv,ncv),intent(in,out) :: v +- integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0) +- integer dimension(11),intent(in,out) :: iparam +- integer dimension(14),intent(in,out) :: ipntr +- <_rd> dimension(3 * n),depend(n),intent(inout) :: workd +- <_rd> dimension(lworkl),intent(inout) :: workl +- integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl) +- integer intent(in,out):: info +- end subroutine naupd +- +- subroutine neupd(rvec,howmny,select,dr,di,z,ldz,sigmar,sigmai,workev,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in ARPACK/SRC/sneupd.f +- threadsafe ! it's not really threadsafe, but we use a lock on the Python side, so keeping GIL is not needed +- logical :: rvec +- character :: howmny +- logical dimension(ncv) :: select +- <_rd> dimension(nev + 1),depend(nev),intent(out) :: dr +- <_rd> dimension(nev + 1),depend(nev),intent(out) :: di +- <_rd> dimension(n,nev+1),depend(n,nev),intent(out) :: z +- integer optional,check(shape(z,0)==ldz),depend(z) :: ldz=shape(z,0) +- <_rd> :: sigmar +- <_rd> :: sigmai +- <_rd> dimension(3 * ncv),depend(ncv) :: workev +- character :: bmat +- integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid) +- character*2 :: which +- integer :: nev +- <_rd> :: tol +- <_rd> dimension(n) :: resid +- integer optional,check(len(select)>=ncv),depend(select) :: ncv=len(select) +- <_rd> dimension(n,ncv),depend(n,ncv) :: v +- integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0) +- integer dimension(11) :: iparam +- integer dimension(14) :: ipntr +- <_rd> dimension(3 * n),depend(n):: workd +- <_rd> dimension(lworkl) :: workl +- integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl) +- integer intent(in,out):: info +- end subroutine neupd +- +- subroutine naupd(ido,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,rwork,info) ! in :_arpack:src/snaupd.f +- threadsafe ! it's not really threadsafe, but we use a lock on the Python side, so keeping GIL is not needed +- integer intent(in,out):: ido +- character*1 :: bmat +- integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid) +- character*2 :: which +- integer :: nev +- <_rd>, intent(in,out) :: tol +- <_cd> dimension(n),intent(in,out) :: resid +- integer optional,check(shape(v,1)==ncv),depend(v) :: ncv=shape(v,1) +- <_cd> dimension(ldv,ncv),intent(in,out) :: v +- integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0) +- integer dimension(11),intent(in,out) :: iparam +- integer dimension(14),intent(in,out) :: ipntr +- <_cd> dimension(3 * n),depend(n),intent(inout) :: workd +- <_cd> dimension(lworkl),intent(inout) :: workl +- integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl) +- <_rd> dimension(ncv),depend(ncv),intent(inout) :: rwork +- integer intent(in,out):: info +- end subroutine naupd +- +- subroutine neupd(rvec,howmny,select,d,z,ldz,sigma,workev,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,rwork,info) ! in :_arpack:src/sneupd.f +- threadsafe ! it's not really threadsafe, but we use a lock on the Python side, so keeping GIL is not needed +- logical :: rvec +- character :: howmny +- logical dimension(ncv) :: select +- <_cd> dimension(nev),depend(nev),intent(out) :: d +- <_cd> dimension(n,nev), depend(n,nev),intent(out) :: z +- integer optional,check(shape(z,0)==ldz),depend(z) :: ldz=shape(z,0) +- <_cd> :: sigma +- <_cd> dimension(3 * ncv),depend(ncv) :: workev +- character :: bmat +- integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid) +- character*2 :: which +- integer :: nev +- <_rd> :: tol +- <_cd> dimension(n) :: resid +- integer optional,check(len(select)>=ncv),depend(select) :: ncv=len(select) +- <_cd> dimension(ldv,ncv),depend(ncv) :: v +- integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0) +- integer dimension(11) :: iparam +- integer dimension(14) :: ipntr +- <_cd> dimension(3 * n),depend(n) :: workd +- <_cd> dimension(lworkl) :: workl +- integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl) +- <_rd> dimension(ncv),depend(ncv) :: rwork +- integer intent(in,out):: info +- end subroutine neupd +- integer :: logfil +- integer :: ndigit +- integer :: mgetv0 +- integer :: msaupd +- integer :: msaup2 +- integer :: msaitr +- integer :: mseigt +- integer :: msapps +- integer :: msgets +- integer :: mseupd +- integer :: mnaupd +- integer :: mnaup2 +- integer :: mnaitr +- integer :: mneigh +- integer :: mnapps +- integer :: mngets +- integer :: mneupd +- integer :: mcaupd +- integer :: mcaup2 +- integer :: mcaitr +- integer :: mceigh +- integer :: mcapps +- integer :: mcgets +- integer :: mceupd +- integer :: nopx +- integer :: nbx +- integer :: nrorth +- integer :: nitref +- integer :: nrstrt +- real :: tsaupd +- real :: tsaup2 +- real :: tsaitr +- real :: tseigt +- real :: tsgets +- real :: tsapps +- real :: tsconv +- real :: tnaupd +- real :: tnaup2 +- real :: tnaitr +- real :: tneigh +- real :: tngets +- real :: tnapps +- real :: tnconv +- real :: tcaupd +- real :: tcaup2 +- real :: tcaitr +- real :: tceigh +- real :: tcgets +- real :: tcapps +- real :: tcconv +- real :: tmvopx +- real :: tmvbx +- real :: tgetv0 +- real :: titref +- real :: trvec +- common /debug/ logfil,ndigit,mgetv0,msaupd,msaup2,msaitr,mseigt,msapps,msgets,mseupd,mnaupd,mnaup2,mnaitr,mneigh,mnapps,mngets,mneupd,mcaupd,mcaup2,mcaitr,mceigh,mcapps,mcgets,mceupd +- common /timing/ nopx,nbx,nrorth,nitref,nrstrt,tsaupd,tsaup2,tsaitr,tseigt,tsgets,tsapps,tsconv,tnaupd,tnaup2,tnaitr,tneigh,tngets,tnapps,tnconv,tcaupd,tcaup2,tcaitr,tceigh,tcgets,tcapps,tcconv,tmvopx,tmvbx,tgetv0,titref,trvec +- +- end interface +-end python module _arpack +- +-! This file was auto-generated with f2py (version:2_3198). +-! See http://cens.ioc.ee/projects/f2py2e/ +diff --git a/scipy/sparse/linalg/_eigen/arpack/meson.build b/scipy/sparse/linalg/_eigen/arpack/meson.build +index 52c8ab968b..c183fcfa88 100644 +--- a/scipy/sparse/linalg/_eigen/arpack/meson.build ++++ b/scipy/sparse/linalg/_eigen/arpack/meson.build +@@ -1,120 +1,36 @@ + arpack_sources = [ +- 'ARPACK/SRC/ccdotc.f', +- 'ARPACK/SRC/cgetv0.f', +- 'ARPACK/SRC/cnaitr.f', +- 'ARPACK/SRC/cnapps.f', +- 'ARPACK/SRC/cnaup2.f', +- 'ARPACK/SRC/cnaupd.f', +- 'ARPACK/SRC/cneigh.f', +- 'ARPACK/SRC/cneupd.f', +- 'ARPACK/SRC/cngets.f', +- 'ARPACK/SRC/csortc.f', +- 'ARPACK/SRC/cstatn.f', +- 'ARPACK/SRC/dgetv0.f', +- 'ARPACK/SRC/dnaitr.f', +- 'ARPACK/SRC/dnapps.f', +- 'ARPACK/SRC/dnaup2.f', +- 'ARPACK/SRC/dnaupd.f', +- 'ARPACK/SRC/dnconv.f', +- 'ARPACK/SRC/dneigh.f', +- 'ARPACK/SRC/dneupd.f', +- 'ARPACK/SRC/dngets.f', +- 'ARPACK/SRC/dsaitr.f', +- 'ARPACK/SRC/dsapps.f', +- 'ARPACK/SRC/dsaup2.f', +- 'ARPACK/SRC/dsaupd.f', +- 'ARPACK/SRC/dsconv.f', +- 'ARPACK/SRC/dseigt.f', +- 'ARPACK/SRC/dsesrt.f', +- 'ARPACK/SRC/dseupd.f', +- 'ARPACK/SRC/dsgets.f', +- 'ARPACK/SRC/dsortc.f', +- 'ARPACK/SRC/dsortr.f', +- 'ARPACK/SRC/dstatn.f', +- 'ARPACK/SRC/dstats.f', +- 'ARPACK/SRC/dstqrb.f', +- 'ARPACK/SRC/sgetv0.f', +- 'ARPACK/SRC/snaitr.f', +- 'ARPACK/SRC/snapps.f', +- 'ARPACK/SRC/snaup2.f', +- 'ARPACK/SRC/snaupd.f', +- 'ARPACK/SRC/snconv.f', +- 'ARPACK/SRC/sneigh.f', +- 'ARPACK/SRC/sneupd.f', +- 'ARPACK/SRC/sngets.f', +- 'ARPACK/SRC/ssaitr.f', +- 'ARPACK/SRC/ssapps.f', +- 'ARPACK/SRC/ssaup2.f', +- 'ARPACK/SRC/ssaupd.f', +- 'ARPACK/SRC/ssconv.f', +- 'ARPACK/SRC/sseigt.f', +- 'ARPACK/SRC/ssesrt.f', +- 'ARPACK/SRC/sseupd.f', +- 'ARPACK/SRC/ssgets.f', +- 'ARPACK/SRC/ssortc.f', +- 'ARPACK/SRC/ssortr.f', +- 'ARPACK/SRC/sstatn.f', +- 'ARPACK/SRC/sstats.f', +- 'ARPACK/SRC/sstqrb.f', +- 'ARPACK/SRC/zgetv0.f', +- 'ARPACK/SRC/znaitr.f', +- 'ARPACK/SRC/znapps.f', +- 'ARPACK/SRC/znaup2.f', +- 'ARPACK/SRC/znaupd.f', +- 'ARPACK/SRC/zneigh.f', +- 'ARPACK/SRC/zneupd.f', +- 'ARPACK/SRC/zngets.f', +- 'ARPACK/SRC/zsortc.f', +- 'ARPACK/SRC/zstatn.f', +- 'ARPACK/SRC/zzdotc.f', +- 'ARPACK/UTIL/cmout.f', +- 'ARPACK/UTIL/cvout.f', +- 'ARPACK/UTIL/dmout.f', +- 'ARPACK/UTIL/dvout.f', +- 'ARPACK/UTIL/icnteq.f', +- 'ARPACK/UTIL/icopy.f', +- 'ARPACK/UTIL/iset.f', +- 'ARPACK/UTIL/iswap.f', +- 'ARPACK/UTIL/ivout.f', +- 'ARPACK/UTIL/second_NONE.f', +- 'ARPACK/UTIL/smout.f', +- 'ARPACK/UTIL/svout.f', +- 'ARPACK/UTIL/zmout.f', +- 'ARPACK/UTIL/zvout.f' ++ 'ARPACK/_arpack.h', ++ 'ARPACK/_arpack_n_single.c', ++ 'ARPACK/_arpack_n_double.c', ++ 'ARPACK/_arpack_n_single_complex.c', ++ 'ARPACK/_arpack_n_double_complex.c', ++ 'ARPACK/_arpack_s_single.c', ++ 'ARPACK/_arpack_s_double.c', ++ 'ARPACK/_arpack_n_single.h', ++ 'ARPACK/_arpack_n_double.h', ++ 'ARPACK/_arpack_n_single_complex.h', ++ 'ARPACK/_arpack_n_double_complex.h', ++ 'ARPACK/_arpack_s_double.h', ++ 'ARPACK/_arpack_s_single.h' + ] + +-# Building ARPACK yields a ton of rank mismatch (scalar and rank-1) warnings +-# that cannot be suppressed with a more specific flag. +-_suppress_all_warnings = ff.get_supported_arguments('-w') +- +-arpack_lib = static_library('arpack_lib', ++arpack_lib = static_library('_arpack', + arpack_sources, +- fortran_args: [fortran_ignore_warnings, _suppress_all_warnings], +- include_directories: ['ARPACK/SRC'], +- override_options: ['b_lto=false'], +- gnu_symbol_visibility: 'hidden', +-) +- +-arpack_module = custom_target('arpack_module', +- output: ['_arpackmodule.c', '_arpack-f2pywrappers.f'], +- input: 'arpack.pyf.src', +- command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] + f2py_freethreading_arg, ++ dependencies: [m_dep, lapack_dep, blas_dep], + ) + +-_arpack = py3.extension_module('_arpack', +- arpack_module, ++py3.extension_module('_arpacklib', ++ '_arpackmodule.c', + link_with: arpack_lib, ++ dependencies: [np_dep], + link_args: version_link_args, +- dependencies: [lapack_dep, blas_dep, fortranobject_dep], + install: true, +- link_language: 'fortran', +- subdir: 'scipy/sparse/linalg/_eigen/arpack' ++ subdir: 'scipy/sparse/linalg/_eigen/arpack', + ) + + py3.install_sources([ + '__init__.py', + 'arpack.py', +- 'ARPACK/COPYING' + ], + subdir: 'scipy/sparse/linalg/_eigen/arpack' + ) +diff --git a/scipy/sparse/linalg/_eigen/arpack/tests/test_arpack.py b/scipy/sparse/linalg/_eigen/arpack/tests/test_arpack.py +index e962798a9f..6b50890c32 100644 +--- a/scipy/sparse/linalg/_eigen/arpack/tests/test_arpack.py ++++ b/scipy/sparse/linalg/_eigen/arpack/tests/test_arpack.py +@@ -1,9 +1,3 @@ +-__usage__ = """ +-To run tests locally: +- python tests/test_arpack.py [-l] [-v] +- +-""" +- + import threading + import itertools + +@@ -13,7 +7,7 @@ from numpy.testing import assert_allclose, assert_equal, suppress_warnings + from pytest import raises as assert_raises + import pytest + +-from numpy import dot, conj, random ++from numpy import dot, conj + from scipy.linalg import eig, eigh + from scipy.sparse import csc_array, csr_array, diags_array, random_array + from scipy.sparse.linalg import LinearOperator, aslinearoperator +@@ -189,7 +183,7 @@ def argsort_which(eigenvalues, typ, k, which, + + + def eval_evec(symmetric, d, typ, k, which, v0=None, sigma=None, +- mattype=np.asarray, OPpart=None, mode='normal'): ++ mattype=np.asarray, OPpart=None, mode='normal', rng=None): + general = ('bmat' in d) + + if symmetric: +@@ -220,7 +214,7 @@ def eval_evec(symmetric, d, typ, k, which, v0=None, sigma=None, + exact_eval = exact_eval[ind] + + # compute arpack eigenvalues +- kwargs = dict(which=which, v0=v0, sigma=sigma) ++ kwargs = dict(which=which, v0=v0, sigma=sigma, rng=rng) + if eigs_func is eigsh: + kwargs['mode'] = mode + else: +@@ -399,45 +393,38 @@ class NonSymmetricParams: + + + @pytest.mark.iterations(1) +-@pytest.mark.thread_unsafe +-def test_symmetric_modes(num_parallel_threads): ++@pytest.mark.parametrize("sigma, mode", [(None, 'normal'), (0.5, 'normal'), ++ (0.5, 'buckling'), (0.5, 'cayley')]) ++@pytest.mark.parametrize("mattype", [csr_array, aslinearoperator, np.asarray]) ++@pytest.mark.parametrize("which", ['LM', 'SM', 'LA', 'SA', 'BE']) ++@pytest.mark.parametrize("typ", ['f', 'd']) ++@pytest.mark.parametrize("D", SymmetricParams().real_test_cases) ++def test_symmetric_modes(num_parallel_threads, D, typ, which, mattype, ++ sigma, mode): + assert num_parallel_threads == 1 +- params = SymmetricParams() ++ rng = np.random.default_rng(1749531508689996) + k = 2 +- symmetric = True +- for D in params.real_test_cases: +- for typ in 'fd': +- for which in params.which: +- for mattype in params.mattypes: +- for (sigma, modes) in params.sigmas_modes.items(): +- for mode in modes: +- eval_evec(symmetric, D, typ, k, which, +- None, sigma, mattype, None, mode) +- +- +-def test_hermitian_modes(): +- params = SymmetricParams() ++ eval_evec(True, D, typ, k, which, None, sigma, mattype, None, mode, rng=rng) ++ ++ ++@pytest.mark.parametrize("sigma", [None, 0.5]) ++@pytest.mark.parametrize("mattype", [csr_array, aslinearoperator, np.asarray]) ++@pytest.mark.parametrize("which", ['LM', 'SM', 'LA', 'SA']) ++@pytest.mark.parametrize("typ", ['F', 'D']) ++@pytest.mark.parametrize("D", SymmetricParams().complex_test_cases) ++def test_hermitian_modes(D, typ, which, mattype, sigma): ++ rng = np.random.default_rng(1749531706842957) + k = 2 +- symmetric = True +- for D in params.complex_test_cases: +- for typ in 'FD': +- for which in params.which: +- if which == 'BE': +- continue # BE invalid for complex +- for mattype in params.mattypes: +- for sigma in params.sigmas_modes: +- eval_evec(symmetric, D, typ, k, which, +- None, sigma, mattype) +- +- +-def test_symmetric_starting_vector(): +- params = SymmetricParams() +- symmetric = True +- for k in [1, 2, 3, 4, 5]: +- for D in params.real_test_cases: +- for typ in 'fd': +- v0 = random.rand(len(D['v0'])).astype(typ) +- eval_evec(symmetric, D, typ, k, 'LM', v0) ++ eval_evec(True, D, typ, k, which, None, sigma, mattype, rng=rng) ++ ++ ++@pytest.mark.parametrize("typ", ['f', 'd']) ++@pytest.mark.parametrize("D", SymmetricParams().real_test_cases) ++@pytest.mark.parametrize("k", [1, 2, 3, 4, 5]) ++def test_symmetric_starting_vector(k, D, typ): ++ rng = np.random.default_rng(1749532110418901) ++ v0 = rng.uniform(size=len(D['v0'])).astype(typ) ++ eval_evec(True, D, typ, k, 'LM', v0, rng=rng) + + + def test_symmetric_no_convergence(): +@@ -455,57 +442,39 @@ def test_symmetric_no_convergence(): + assert_allclose(dot(m, v), w * v, rtol=rtol, atol=atol) + + +-def test_real_nonsymmetric_modes(): +- params = NonSymmetricParams() ++@pytest.mark.parametrize("sigma, OPpart", [(None, None), (0.1, 'r'), ++ (0.1 + 0.1j, 'r'), (0.1 + 0.1j, 'i')]) ++@pytest.mark.parametrize("mattype", [csr_array, aslinearoperator, np.asarray]) ++@pytest.mark.parametrize("which", ['LM', 'LR', 'LI']) ++@pytest.mark.parametrize("typ", ['f', 'd']) ++@pytest.mark.parametrize("D", NonSymmetricParams().real_test_cases) ++def test_real_nonsymmetric_modes(D, typ, which, mattype, ++ sigma, OPpart): ++ rng = np.random.default_rng(174953334412726) + k = 2 +- symmetric = False +- for D in params.real_test_cases: +- for typ in 'fd': +- for which in params.which: +- for mattype in params.mattypes: +- for sigma, OPparts in params.sigmas_OPparts.items(): +- for OPpart in OPparts: +- eval_evec(symmetric, D, typ, k, which, +- None, sigma, mattype, OPpart) +- +- +-def test_complex_nonsymmetric_modes(): +- params = NonSymmetricParams() ++ eval_evec(False, D, typ, k, which, None, sigma, mattype, OPpart, rng=rng) ++ ++ ++@pytest.mark.parametrize("sigma", [None, 0.1, 0.1 + 0.1j]) ++@pytest.mark.parametrize("mattype", [csr_array, aslinearoperator, np.asarray]) ++@pytest.mark.parametrize("which", ['LM', 'LR', 'LI']) ++@pytest.mark.parametrize("typ", ['F', 'D']) ++@pytest.mark.parametrize("D", NonSymmetricParams().complex_test_cases) ++def test_complex_nonsymmetric_modes(D, typ, which, mattype, sigma): ++ rng = np.random.default_rng(1749533536274527) + k = 2 +- symmetric = False +- for D in params.complex_test_cases: +- for typ in 'DF': +- for which in params.which: +- for mattype in params.mattypes: +- for sigma in params.sigmas_OPparts: +- eval_evec(symmetric, D, typ, k, which, +- None, sigma, mattype) +- +- +-def test_standard_nonsymmetric_starting_vector(): +- params = NonSymmetricParams() +- sigma = None +- symmetric = False +- for k in [1, 2, 3, 4]: +- for d in params.complex_test_cases: +- for typ in 'FD': +- A = d['mat'] +- n = A.shape[0] +- v0 = random.rand(n).astype(typ) +- eval_evec(symmetric, d, typ, k, "LM", v0, sigma) +- +- +-def test_general_nonsymmetric_starting_vector(): +- params = NonSymmetricParams() +- sigma = None +- symmetric = False +- for k in [1, 2, 3, 4]: +- for d in params.complex_test_cases: +- for typ in 'FD': +- A = d['mat'] +- n = A.shape[0] +- v0 = random.rand(n).astype(typ) +- eval_evec(symmetric, d, typ, k, "LM", v0, sigma) ++ eval_evec(False, D, typ, k, which, None, sigma, mattype, rng=rng) ++ ++ ++@pytest.mark.parametrize("typ", ['F', 'D']) ++@pytest.mark.parametrize("D", NonSymmetricParams().complex_test_cases) ++@pytest.mark.parametrize("k", [1, 2, 3, 4]) ++def test_nonsymmetric_starting_vector(k, D, typ): ++ rng = np.random.default_rng(174953366983161) ++ A = D['mat'] ++ n = A.shape[0] ++ v0 = rng.uniform(size=n).astype(typ) ++ eval_evec(False, D, typ, k, "LM", v0, sigma=None, rng=rng) + + + def test_standard_nonsymmetric_no_convergence(): +@@ -578,7 +547,6 @@ def test_linearoperator_deallocation(): + pass + + +-@pytest.mark.thread_unsafe + def test_parallel_threads(): + results = [] + v0 = np.random.rand(50) +@@ -608,12 +576,17 @@ def test_reentering(): + def A_matvec(x): + x = diags_array([1, -2, 1], offsets=[-1, 0, 1], shape=(50, 50)) + w, v = eigs(x, k=1) +- return v / w[0] ++ return v.real / w[0].real + A = LinearOperator(matvec=A_matvec, dtype=float, shape=(50, 50)) + ++ # ================= Old Fortran tests ================== + # The Fortran code is not reentrant, so this fails (gracefully, not crashing) +- assert_raises(RuntimeError, eigs, A, k=1) +- assert_raises(RuntimeError, eigsh, A, k=1) ++ # assert_raises(RuntimeError, eigs, A, k=1) ++ # assert_raises(RuntimeError, eigsh, A, k=1) ++ # ++ # These should not crash upon reentrance ++ eigs(A, k=1) ++ eigsh(A, k=1) + + + def test_regression_arpackng_1315(): +-- +2.39.5 (Apple Git-154) + diff --git a/packages/scipy/patches/0014-Remove-f2py-generators.patch b/packages/scipy/patches/0014-Remove-f2py-generators.patch new file mode 100644 index 00000000..b22151d6 --- /dev/null +++ b/packages/scipy/patches/0014-Remove-f2py-generators.patch @@ -0,0 +1,177 @@ +From 9b670bd5330bd7834d157a9ec3087a97b71d6516 Mon Sep 17 00:00:00 2001 +From: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> +Date: Fri, 16 Aug 2024 22:59:26 +0530 +Subject: [PATCH 14/14] Remove f2py generators +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +This patch reverts changes made in d85ba6b910ea9040b6a72bdc4ea87d151118f41d +and is applied at the end, after the rest of the patches – the order is important. + +It removes the f2py generator and replaces it with custom targets mapping to +f2py-generated wrappers. This is done to avoid the need for the f2py executable +to be present in the environment where SciPy is built. Instead, the Python +executable is used to run f2py as a module which is useful where f2py is not +present on PATH. + +--- + scipy/integrate/meson.build | 24 +++++++++++++++++++++--- + scipy/interpolate/meson.build | 8 +++++++- + scipy/meson.build | 24 ------------------------ + scipy/sparse/linalg/_propack/meson.build | 8 +++++++- + tools/generate_f2pymod.py | 3 ++- + 5 files changed, 37 insertions(+), 30 deletions(-) + +diff --git a/scipy/integrate/meson.build b/scipy/integrate/meson.build +index 30f738a077..a012bdc11b 100644 +--- a/scipy/integrate/meson.build ++++ b/scipy/integrate/meson.build +@@ -79,8 +79,14 @@ py3.extension_module('_odepack', + subdir: 'scipy/integrate' + ) + ++vode_module = custom_target('vode_module', ++ output: ['_vode-f2pywrappers.f', '_vodemodule.c'], ++ input: 'vode.pyf', ++ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] ++) ++ + py3.extension_module('_vode', +- f2py_gen.process('vode.pyf'), ++ vode_module, + link_with: [vode_lib], + c_args: [Wno_unused_variable], + link_args: version_link_args, +@@ -90,8 +96,14 @@ py3.extension_module('_vode', + subdir: 'scipy/integrate' + ) + ++lsoda_module = custom_target('lsoda_module', ++ output: ['_lsoda-f2pywrappers.f', '_lsodamodule.c'], ++ input: 'lsoda.pyf', ++ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] ++) ++ + py3.extension_module('_lsoda', +- f2py_gen.process('lsoda.pyf'), ++ lsoda_module, + link_with: [lsoda_lib, mach_lib], + c_args: [Wno_unused_variable], + dependencies: [lapack_dep, fortranobject_dep], +@@ -101,8 +113,14 @@ py3.extension_module('_lsoda', + subdir: 'scipy/integrate' + ) + ++_dop_module = custom_target('_dop_module', ++ output: ['_dop-f2pywrappers.f', '_dopmodule.c'], ++ input: 'dop.pyf', ++ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] ++) ++ + py3.extension_module('_dop', +- f2py_gen.process('dop.pyf'), ++ _dop_module, + link_with: [dop_lib], + c_args: [Wno_unused_variable], + dependencies: [lapack, fortranobject_dep], +diff --git a/scipy/interpolate/meson.build b/scipy/interpolate/meson.build +index e0e2867b18..9041cf7022 100644 +--- a/scipy/interpolate/meson.build ++++ b/scipy/interpolate/meson.build +@@ -151,9 +151,15 @@ py3.extension_module('_fitpack', + subdir: 'scipy/interpolate' + ) + ++dfitpack_module = custom_target('dfitpack_module', ++ output: ['_dfitpack-f2pywrappers.f', '_dfitpackmodule.c'], ++ input: 'src/dfitpack.pyf', ++ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] ++) ++ + # TODO: Add flags for 64 bit ints + py3.extension_module('_dfitpack', +- f2py_gen.process('src/dfitpack.pyf'), ++ dfitpack_module, + c_args: [Wno_unused_variable], + link_args: version_link_args, + dependencies: [lapack_dep, fortranobject_dep], +diff --git a/scipy/meson.build b/scipy/meson.build +index 1bc50f5026..77034140eb 100644 +--- a/scipy/meson.build ++++ b/scipy/meson.build +@@ -199,30 +199,6 @@ fortranobject_dep = declare_dependency( + compile_args: _f2py_c_args, + ) + +-f2py = find_program('f2py') +-# It should be quite rare for the `f2py` executable to not be the one from +-# `numpy` installed in the Python env we are building for (unless we are +-# cross-compiling). If it is from a different env, that is still fine as long +-# as it's not too old. We are only using f2py as a code generator, and the +-# output is not dependent on platform or Python version (see gh-20612 for more +-# details). +-# This should be robust enough. If not, we can make this more complex, using +-# a fallback to `python -m f2py` rather than erroring out. +-f2py_version = run_command([f2py, '-v'], check: true).stdout().strip() +-if f2py_version.version_compare('<'+min_numpy_version) +- error(f'Found f2py executable is too old: @f2py_version@') +-endif +- +-# Note: this generator cannot handle: +-# 1. `.pyf.src` files, because `@BASENAME@` will still include .pyf +-# 2. targets with #include's (due to no `depend_files` - see feature request +-# at meson#8295) +-f2py_gen = generator(generate_f2pymod, +- arguments : ['@INPUT@', '-o', '@BUILD_DIR@'] + f2py_freethreading_arg, +- output : ['_@BASENAME@module.c', '_@BASENAME@-f2pywrappers.f'], +-) +- +- + # TODO: 64-bit BLAS and LAPACK + # + # Note that this works as long as BLAS and LAPACK are detected properly via +diff --git a/scipy/sparse/linalg/_propack/meson.build b/scipy/sparse/linalg/_propack/meson.build +index d33cdc0e76..867aa4de82 100644 +--- a/scipy/sparse/linalg/_propack/meson.build ++++ b/scipy/sparse/linalg/_propack/meson.build +@@ -99,8 +99,14 @@ foreach ele: elements + gnu_symbol_visibility: 'hidden', + ) + ++ propack_module = custom_target('propack_module' + ele[0], ++ output: [ele[0] + '-f2pywrappers.f', ele[0] + 'module.c'], ++ input: ele[2], ++ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] ++ ) ++ + propacklib = py3.extension_module(ele[0], +- f2py_gen.process(ele[2]), ++ propack_module, + link_with: propack_lib, + c_args: ['-U_OPENMP', _cpp_Wno_cpp], + fortran_args: _fflag_Wno_maybe_uninitialized, +diff --git a/tools/generate_f2pymod.py b/tools/generate_f2pymod.py +index e61524cc39..85e480b5ef 100644 +--- a/tools/generate_f2pymod.py ++++ b/tools/generate_f2pymod.py +@@ -9,6 +9,7 @@ import argparse + import os + import re + import subprocess ++import sys + + + # START OF CODE VENDORED FROM `numpy.distutils.from_template` +@@ -291,7 +292,7 @@ def main(): + # Now invoke f2py to generate the C API module file + if args.infile.endswith(('.pyf.src', '.pyf')): + p = subprocess.Popen( +- ['f2py', fname_pyf, '--build-dir', outdir_abs] + nogil_arg, ++ [sys.executable, '-m', 'numpy.f2py', fname_pyf, '--build-dir', outdir_abs] + nogil_arg, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, cwd=os.getcwd() + ) + out, err = p.communicate() +-- +2.39.5 (Apple Git-154) + diff --git a/packages/scipy/patches/0014-Skip-svd_gesdd-test.patch b/packages/scipy/patches/0014-Skip-svd_gesdd-test.patch deleted file mode 100644 index b9e521f3..00000000 --- a/packages/scipy/patches/0014-Skip-svd_gesdd-test.patch +++ /dev/null @@ -1,51 +0,0 @@ -From 59d3efdf9e55958c6a3651e8eda2a9d6fe48e192 Mon Sep 17 00:00:00 2001 -From: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> -Date: Fri, 9 Aug 2024 19:00:41 +0530 -Subject: [PATCH 14/18] Skip svd_gesdd test - -This patch excludes a test for gesdd which was introduced in this PR: -https://github.com/scipy/scipy/pull/20349. It is not useful for Pyodide -since it is a memory-intensive test and it is not expected to pass in -a WASM environment where allocating memory for large arrays is tricky. - -This patch has been upstreamed in https://github.com/scipy/scipy/pull/21349 -and it can be safely removed once SciPy v1.15.0 is released and is being -integrated in Pyodide. - ---- - scipy/linalg/tests/test_decomp.py | 6 ++++++ - 1 file changed, 6 insertions(+) - -diff --git a/scipy/linalg/tests/test_decomp.py b/scipy/linalg/tests/test_decomp.py -index b43016c027..cbd80252b1 100644 ---- a/scipy/linalg/tests/test_decomp.py -+++ b/scipy/linalg/tests/test_decomp.py -@@ -1,5 +1,6 @@ - import itertools - import platform -+import sys - - import numpy as np - from numpy.testing import (assert_equal, assert_almost_equal, -@@ -37,6 +38,8 @@ try: - except ImportError: - CONFIG = None - -+IS_WASM = (sys.platform == "emscripten" or platform.machine() in ["wasm32", "wasm64"]) -+ - - def _random_hermitian_matrix(n, posdef=False, dtype=float): - "Generate random sym/hermitian array of the given size n" -@@ -1179,6 +1182,9 @@ class TestSVD_GESVD(TestSVD_GESDD): - lapack_driver = 'gesvd' - - -+# Allocating an array of such a size leads to _ArrayMemoryError(s) -+# since the maximum memory that can be in 32-bit (WASM) is 4GB -+@pytest.mark.skipif(IS_WASM, reason="out of memory in WASM") - @pytest.mark.fail_slow(5) - def test_svd_gesdd_nofegfault(): - # svd(a) with {U,VT}.size > INT_MAX does not segfault --- -2.39.3 (Apple Git-146) - diff --git a/packages/scipy/patches/0015-Remove-f2py-generators.patch b/packages/scipy/patches/0015-Remove-f2py-generators.patch deleted file mode 100644 index a80ca320..00000000 --- a/packages/scipy/patches/0015-Remove-f2py-generators.patch +++ /dev/null @@ -1,304 +0,0 @@ -From 9b670bd5330bd7834d157a9ec3087a97b71d6516 Mon Sep 17 00:00:00 2001 -From: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> -Date: Fri, 16 Aug 2024 22:59:26 +0530 -Subject: [PATCH 15/18] Remove f2py generators -MIME-Version: 1.0 -Content-Type: text/plain; charset=UTF-8 -Content-Transfer-Encoding: 8bit - -This patch reverts changes made in d85ba6b910ea9040b6a72bdc4ea87d151118f41d -and is applied at the end, after the rest of the patches – the order is important. - -It removes the f2py generator and replaces it with custom targets mapping to -f2py-generated wrappers. This is done to avoid the need for the f2py executable -to be present in the environment where SciPy is built. Instead, the Python -executable is used to run f2py as a module which is useful where f2py is not -present on PATH. - ---- - scipy/integrate/meson.build | 32 +++++++++++++++++++++--- - scipy/interpolate/meson.build | 8 +++++- - scipy/io/meson.build | 8 +++++- - scipy/meson.build | 24 ------------------ - scipy/optimize/meson.build | 30 +++++++++++++++++++--- - scipy/sparse/linalg/_propack/meson.build | 8 +++++- - scipy/stats/meson.build | 8 +++++- - tools/generate_f2pymod.py | 3 ++- - 8 files changed, 85 insertions(+), 36 deletions(-) - -diff --git a/scipy/integrate/meson.build b/scipy/integrate/meson.build -index cfaa927139..44c63fa526 100644 ---- a/scipy/integrate/meson.build -+++ b/scipy/integrate/meson.build -@@ -128,8 +128,14 @@ py3.extension_module('_odepack', - subdir: 'scipy/integrate' - ) - -+vode_module = custom_target('vode_module', -+ output: ['_vode-f2pywrappers.f', '_vodemodule.c'], -+ input: 'vode.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_vode', -- f2py_gen.process('vode.pyf'), -+ vode_module, - link_with: [vode_lib], - c_args: [Wno_unused_variable], - link_args: version_link_args, -@@ -139,8 +145,14 @@ py3.extension_module('_vode', - subdir: 'scipy/integrate' - ) - -+lsoda_module = custom_target('lsoda_module', -+ output: ['_lsoda-f2pywrappers.f', '_lsodamodule.c'], -+ input: 'lsoda.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_lsoda', -- f2py_gen.process('lsoda.pyf'), -+ lsoda_module, - link_with: [lsoda_lib, mach_lib], - c_args: [Wno_unused_variable], - dependencies: [lapack_dep, fortranobject_dep], -@@ -150,8 +162,14 @@ py3.extension_module('_lsoda', - subdir: 'scipy/integrate' - ) - -+_dop_module = custom_target('_dop_module', -+ output: ['_dop-f2pywrappers.f', '_dopmodule.c'], -+ input: 'dop.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_dop', -- f2py_gen.process('dop.pyf'), -+ _dop_module, - link_with: [dop_lib], - c_args: [Wno_unused_variable], - dependencies: [lapack, fortranobject_dep], -@@ -169,8 +187,14 @@ py3.extension_module('_test_multivariate', - install_tag: 'tests' - ) - -+_test_odeint_banded_module = custom_target('_test_odeint_banded_module', -+ output: ['_test_odeint_bandedmodule.c', '_test_odeint_banded-f2pywrappers.f'], -+ input: 'tests/test_odeint_banded.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_test_odeint_banded', -- ['tests/banded5x5.f', f2py_gen.process('tests/test_odeint_banded.pyf')], -+ ['tests/banded5x5.f', _test_odeint_banded_module], - link_with: [lsoda_lib, mach_lib], - fortran_args: _fflag_Wno_unused_dummy_argument, - link_args: version_link_args, -diff --git a/scipy/interpolate/meson.build b/scipy/interpolate/meson.build -index 69ec25f6af..38dd2a8cc3 100644 ---- a/scipy/interpolate/meson.build -+++ b/scipy/interpolate/meson.build -@@ -143,9 +143,15 @@ py3.extension_module('_fitpack', - subdir: 'scipy/interpolate' - ) - -+dfitpack_module = custom_target('dfitpack_module', -+ output: ['_dfitpack-f2pywrappers.f', '_dfitpackmodule.c'], -+ input: 'src/dfitpack.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - # TODO: Add flags for 64 bit ints - py3.extension_module('_dfitpack', -- f2py_gen.process('src/dfitpack.pyf'), -+ dfitpack_module, - c_args: [Wno_unused_variable], - link_args: version_link_args, - dependencies: [lapack_dep, fortranobject_dep], -diff --git a/scipy/io/meson.build b/scipy/io/meson.build -index 60f71c6968..89a9cf69ba 100644 ---- a/scipy/io/meson.build -+++ b/scipy/io/meson.build -@@ -1,6 +1,12 @@ -+_test_fortran_module = custom_target('_test_fortran_module', -+ output: ['_test_fortranmodule.c'], -+ input: 'test_fortran.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_test_fortran', - [ -- f2py_gen.process('test_fortran.pyf'), -+ _test_fortran_module, - '_test_fortran.f' - ], - c_args: [Wno_unused_variable], -diff --git a/scipy/meson.build b/scipy/meson.build -index a0857848a2..ff47bde52e 100644 ---- a/scipy/meson.build -+++ b/scipy/meson.build -@@ -144,30 +144,6 @@ fortranobject_dep = declare_dependency( - compile_args: _f2py_c_args, - ) - --f2py = find_program('f2py') --# It should be quite rare for the `f2py` executable to not be the one from --# `numpy` installed in the Python env we are building for (unless we are --# cross-compiling). If it is from a different env, that is still fine as long --# as it's not too old. We are only using f2py as a code generator, and the --# output is not dependent on platform or Python version (see gh-20612 for more --# details). --# This should be robust enough. If not, we can make this more complex, using --# a fallback to `python -m f2py` rather than erroring out. --f2py_version = run_command([f2py, '-v'], check: true).stdout().strip() --if f2py_version.version_compare('<'+min_numpy_version) -- error(f'Found f2py executable is too old: @f2py_version@') --endif -- --# Note: this generato cannot handle: --# 1. `.pyf.src` files, because `@BASENAME@` will still include .pyf --# 2. targets with #include's (due to no `depend_files` - see feature request --# at meson#8295) --f2py_gen = generator(generate_f2pymod, -- arguments : ['@INPUT@', '-o', '@BUILD_DIR@'], -- output : ['_@BASENAME@module.c', '_@BASENAME@-f2pywrappers.f'], --) -- -- - # TODO: 64-bit BLAS and LAPACK - # - # Note that this works as long as BLAS and LAPACK are detected properly via -diff --git a/scipy/optimize/meson.build b/scipy/optimize/meson.build -index 50d62ef68b..6cef85027a 100644 ---- a/scipy/optimize/meson.build -+++ b/scipy/optimize/meson.build -@@ -92,12 +92,18 @@ py3.extension_module('_zeros', - subdir: 'scipy/optimize' - ) - -+lbfgsb_module = custom_target('lbfgsb_module', -+ output: ['_lbfgsb-f2pywrappers.f', '_lbfgsbmodule.c'], -+ input: 'lbfgsb_src/lbfgsb.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_lbfgsb', - [ - 'lbfgsb_src/lbfgsb.f', - 'lbfgsb_src/linpack.f', - 'lbfgsb_src/timer.f', -- f2py_gen.process('lbfgsb_src/lbfgsb.pyf'), -+ lbfgsb_module, - ], - fortran_args: fortran_ignore_warnings, - link_args: version_link_args, -@@ -120,6 +126,12 @@ py3.extension_module('_moduleTNC', - subdir: 'scipy/optimize' - ) - -+cobyla_module = custom_target('cobyla_module', -+ output: ['_cobylamodule.c'], -+ input: 'cobyla/cobyla.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_cobyla', -- [f2py_gen.process('cobyla/cobyla.pyf'), 'cobyla/cobyla2.f', 'cobyla/trstlp.f'], -+ [cobyla_module, 'cobyla/cobyla2.f', 'cobyla/trstlp.f'], - c_args: [Wno_unused_variable], -@@ -131,8 +143,14 @@ py3.extension_module('_cobyla', - subdir: 'scipy/optimize' - ) - -+minpack2_module = custom_target('minpack2_module', -+ output: ['_minpack2module.c'], -+ input: 'minpack2/minpack2.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_minpack2', -- [f2py_gen.process('minpack2/minpack2.pyf'), 'minpack2/dcsrch.f', 'minpack2/dcstep.f'], -+ [minpack2_module, 'minpack2/dcsrch.f', 'minpack2/dcstep.f'], - fortran_args: fortran_ignore_warnings, - link_args: version_link_args, - dependencies: [lapack, fortranobject_dep], -@@ -142,8 +160,14 @@ py3.extension_module('_minpack2', - subdir: 'scipy/optimize' - ) - -+slsqp_module = custom_target('slsqp_module', -+ output: ['_slsqpmodule.c'], -+ input: 'slsqp/slsqp.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_slsqp', -- [f2py_gen.process('slsqp/slsqp.pyf'), 'slsqp/slsqp_optmz.f'], -+ [slsqp_module, 'slsqp/slsqp_optmz.f'], - fortran_args: fortran_ignore_warnings, - link_args: version_link_args, - dependencies: [fortranobject_dep], -diff --git a/scipy/sparse/linalg/_propack/meson.build b/scipy/sparse/linalg/_propack/meson.build -index 6714724958..df358df651 100644 ---- a/scipy/sparse/linalg/_propack/meson.build -+++ b/scipy/sparse/linalg/_propack/meson.build -@@ -97,8 +97,14 @@ foreach ele: elements - gnu_symbol_visibility: 'hidden', - ) - -+ propack_module = custom_target('propack_module' + ele[0], -+ output: [ele[0] + '-f2pywrappers.f', ele[0] + 'module.c'], -+ input: ele[2], -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+ ) -+ - propacklib = py3.extension_module(ele[0], -- f2py_gen.process(ele[2]), -+ propack_module, - link_with: propack_lib, - c_args: ['-U_OPENMP', _cpp_Wno_cpp], - fortran_args: _fflag_Wno_maybe_uninitialized, -diff --git a/scipy/stats/meson.build b/scipy/stats/meson.build -index 358279a93b..7c973b1cf3 100644 ---- a/scipy/stats/meson.build -+++ b/scipy/stats/meson.build -@@ -31,8 +31,14 @@ py3.extension_module('_ansari_swilk_statistics', - subdir: 'scipy/stats' - ) - -+mvn_module = custom_target('mvn_module', -+ output: ['_mvn-f2pywrappers.f', '_mvnmodule.c'], -+ input: 'mvn.pyf', -+ command: [generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] -+) -+ - py3.extension_module('_mvn', -- [f2py_gen.process('mvn.pyf'), 'mvndst.f'], -+ [mvn_module, 'mvndst.f'], - # Wno-surprising is to suppress a pointless warning with GCC 10-12 - # (see GCC bug 98411: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98411) - fortran_args: [fortran_ignore_warnings, _fflag_Wno_surprising], -diff --git a/tools/generate_f2pymod.py b/tools/generate_f2pymod.py -index b6bc02eb04..3da75c14d1 100644 ---- a/tools/generate_f2pymod.py -+++ b/tools/generate_f2pymod.py -@@ -9,6 +9,7 @@ import argparse - import os - import re - import subprocess -+import sys - - - # START OF CODE VENDORED FROM `numpy.distutils.from_template` -@@ -283,7 +284,7 @@ def main(): - - # Now invoke f2py to generate the C API module file - if args.infile.endswith(('.pyf.src', '.pyf')): -- p = subprocess.Popen(['f2py', fname_pyf, -+ p = subprocess.Popen([sys.executable, '-m', 'numpy.f2py', fname_pyf, - '--build-dir', outdir_abs], #'--quiet'], - stdout=subprocess.PIPE, stderr=subprocess.PIPE, - cwd=os.getcwd()) --- -2.39.3 (Apple Git-146) - diff --git a/packages/scipy/patches/0016-Make-sf_error_state_lib-a-static-library.patch b/packages/scipy/patches/0016-Make-sf_error_state_lib-a-static-library.patch deleted file mode 100644 index 9f45ad86..00000000 --- a/packages/scipy/patches/0016-Make-sf_error_state_lib-a-static-library.patch +++ /dev/null @@ -1,28 +0,0 @@ -From 9d93ca19f4ad0ca327964b6234316547d774b17f Mon Sep 17 00:00:00 2001 -From: Agriya Khetarpal <74401230+agriyakhetarpal@users.noreply.github.com> -Date: Sat, 17 Aug 2024 01:12:28 +0530 -Subject: [PATCH 16/18] Make `sf_error_state_lib` a static library - -wasm.ld does not support linkage with shared libraries. This patch -changes `sf_error_state_lib` to a static one. - ---- - scipy/special/meson.build | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/scipy/special/meson.build b/scipy/special/meson.build -index 82b813ea85..24bee0a21c 100644 ---- a/scipy/special/meson.build -+++ b/scipy/special/meson.build -@@ -33,7 +33,7 @@ else - scipy_import_dll_args = [] - endif - --sf_error_state_lib = shared_library('sf_error_state', -+sf_error_state_lib = static_library('sf_error_state', - ['sf_error_state.c'], - include_directories: ['../_lib', '../_build_utils/src'], - c_args: scipy_export_dll_args, --- -2.39.3 (Apple Git-146) - diff --git a/pyproject.toml b/pyproject.toml index 3bcdb766..e3d00253 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -81,4 +81,4 @@ asyncio_mode = "strict" [tool.pyodide.build] rust_toolchain = "nightly-2025-02-01" -default_cross_build_env_url = "https://github.com/pyodide/pyodide-build-environment-nightly/releases/download/20250626/xbuildenv.tar.bz2" +default_cross_build_env_url = "https://github.com/pyodide/pyodide-build-environment-nightly/releases/download/20250820/xbuildenv-debug.tar.bz2"