From f9e55695ea16e4e00d0a5f16c423a28b72315d5c Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Fri, 19 Jul 2024 16:55:50 +0900 Subject: [PATCH 1/5] Sync recipes (#41) Co-authored-by: pre-commit-ci[bot] <66853113+pre-commit-ci[bot]@users.noreply.github.com> --- packages/matplotlib/test_matplotlib.py | 2 +- .../opencv-python/extras/detect_ffmpeg.cmake | 4 +- packages/pygame-ce/test_pygame.py | 2 +- packages/pyodide-unix-timezones/meta.yaml | 16 + packages/scipy/meta.yaml | 9 +- ...-Fix-dstevr-in-special-lapack_defs.h.patch | 2 +- .../patches/0001-Make-sreorth-recursive.patch | 111 + .../scipy/patches/0002-int-to-string.patch | 2 +- .../scipy/patches/0003-gemm_-no-const.patch | 2 +- .../patches/0004-make-int-return-values.patch | 2 +- ...ove-test-modules-that-fails-to-build.patch | 2 +- packages/scipy/patches/0006-Fix-fitpack.patch | 2 +- .../scipy/patches/0007-Fix-gees-calls.patch | 2 +- ...-linalg-Remove-id_dist-Fortran-files.patch | 21866 ++++++++++++++++ ...0009-Mark-mvndst-functions-recursive.patch | 38 + packages/scipy/scipy-conftest.py | 263 + packages/scipy/scipy-pytest.js | 84 + 17 files changed, 22397 insertions(+), 12 deletions(-) create mode 100644 packages/pyodide-unix-timezones/meta.yaml create mode 100644 packages/scipy/patches/0001-Make-sreorth-recursive.patch create mode 100644 packages/scipy/patches/0008-MAINT-linalg-Remove-id_dist-Fortran-files.patch create mode 100644 packages/scipy/patches/0009-Mark-mvndst-functions-recursive.patch create mode 100644 packages/scipy/scipy-conftest.py create mode 100644 packages/scipy/scipy-pytest.js diff --git a/packages/matplotlib/test_matplotlib.py b/packages/matplotlib/test_matplotlib.py index 08ba166..44f2535 100644 --- a/packages/matplotlib/test_matplotlib.py +++ b/packages/matplotlib/test_matplotlib.py @@ -152,7 +152,7 @@ def test_font_manager(selenium): # get fontlist from build fontlist_built = json.loads(json.dumps(fm.FontManager(), cls=fm._JSONEncoder)) - # reodering list to compare + # reordering list to compare for list in ("afmlist", "ttflist"): for fontlist in (fontlist_vendor, fontlist_built): fontlist[list].sort(key=lambda x: x["fname"]) diff --git a/packages/opencv-python/extras/detect_ffmpeg.cmake b/packages/opencv-python/extras/detect_ffmpeg.cmake index 772ee62..6b8a797 100644 --- a/packages/opencv-python/extras/detect_ffmpeg.cmake +++ b/packages/opencv-python/extras/detect_ffmpeg.cmake @@ -30,8 +30,8 @@ elseif(OPENCL_INCLUDE_DIR) else() set(__opencl_dirs "${OpenCV_SOURCE_DIR}/3rdparty/include/opencl/1.2") endif() -# extra dependencies for buildin code (OpenCL dir is required for extensions like cl_d3d11.h) -# buildin HAVE_OPENCL is already defined through cvconfig.h +# extra dependencies for building code (OpenCL dir is required for extensions like cl_d3d11.h) +# building HAVE_OPENCL is already defined through cvconfig.h list(APPEND __builtin_include_dirs "${__opencl_dirs}") # extra dependencies for diff --git a/packages/pygame-ce/test_pygame.py b/packages/pygame-ce/test_pygame.py index be6b19f..bd1c905 100644 --- a/packages/pygame-ce/test_pygame.py +++ b/packages/pygame-ce/test_pygame.py @@ -38,7 +38,7 @@ def test_keyboard_input(): from auditwheel_emscripten import get_imports - dist_dir = pytest.pyodide_dist_dir + dist_dir = Path(pytest.pyodide_dist_dir) # type: ignore[attr-defined] wheel_path = next(dist_dir.glob("pygame_ce-*.whl")) assert wheel_path.exists() all_libs = get_imports(wheel_path) diff --git a/packages/pyodide-unix-timezones/meta.yaml b/packages/pyodide-unix-timezones/meta.yaml new file mode 100644 index 0000000..f50dfd1 --- /dev/null +++ b/packages/pyodide-unix-timezones/meta.yaml @@ -0,0 +1,16 @@ +package: + name: pyodide-unix-timezones + version: 1.0.0 + top-level: + - unix_timezones +source: + url: https://files.pythonhosted.org/packages/f8/ab/637ae2629dc3e9ed7c192fb80f7fdefe311677138a5a5032872a115eb918/pyodide_unix_timezones-1.0.0-py3-none-any.whl + sha256: 9146c0eda703728571d8e3859043b0bb819c9ef45b9f32680234fade2e57b424 +about: + home: https://github.com/joemarshall/pyodide-unix-timezones + PyPI: https://pypi.org/project/pyodide-unix-timezones + summary: Helper package to install unix timezone data on Pyodide + license: MIT +extra: + recipe-maintainers: + - joemarshall diff --git a/packages/scipy/meta.yaml b/packages/scipy/meta.yaml index 71fdb47..455b01e 100644 --- a/packages/scipy/meta.yaml +++ b/packages/scipy/meta.yaml @@ -28,6 +28,9 @@ source: - patches/0005-Remove-test-modules-that-fails-to-build.patch - patches/0006-Fix-fitpack.patch - patches/0007-Fix-gees-calls.patch + - patches/0008-MAINT-linalg-Remove-id_dist-Fortran-files.patch + - patches/0009-Mark-mvndst-functions-recursive.patch + - patches/0001-Make-sreorth-recursive.patch build: cflags: | @@ -50,6 +53,11 @@ build: # pyodide-build/pyodide_build/_f2c_fixes.py. script: | set -x + git clone https://github.com/hoodmane/f2c.git --depth 1 + (cd f2c/src && cp makefile.u makefile && sed -i "s/gram.c:/gram.c1:/" makefile && make) + export F2C_PATH=$(pwd)/f2c/src/f2c + + echo F2C_PATH: $F2C_PATH export NPY_BLAS_LIBS="-I$WASM_LIBRARY_DIR/include $WASM_LIBRARY_DIR/lib/libopenblas.so" export NPY_LAPACK_LIBS="-I$WASM_LIBRARY_DIR/include $WASM_LIBRARY_DIR/lib/libopenblas.so" @@ -106,7 +114,6 @@ requirements: - openblas executable: - gfortran - - f2c test: imports: 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 b5d16d0..347225f 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/7] Fix dstevr in special/lapack_defs.h +Subject: [PATCH 1/9] Fix dstevr in special/lapack_defs.h --- scipy/special/lapack_defs.h | 5 ++--- diff --git a/packages/scipy/patches/0001-Make-sreorth-recursive.patch b/packages/scipy/patches/0001-Make-sreorth-recursive.patch new file mode 100644 index 0000000..828fd40 --- /dev/null +++ b/packages/scipy/patches/0001-Make-sreorth-recursive.patch @@ -0,0 +1,111 @@ +From e4d1a570fa8bd4c710e10400822f60232e6408eb Mon Sep 17 00:00:00 2001 +From: Hood Chatham +Date: Sat, 6 Jul 2024 22:33:51 +0200 +Subject: [PATCH] Make sreorth recursive + +--- + complex16/zreorth.F | 6 +++--- + complex8/creorth.F | 6 +++--- + double/dreorth.F | 6 +++--- + single/sreorth.F | 6 +++--- + 4 files changed, 12 insertions(+), 12 deletions(-) + +diff --git a/scipy/sparse/linalg/_propack/PROPACK/complex16/zreorth.F b/scipy/sparse/linalg/_propack/PROPACK/complex16/zreorth.F +index ca74f7a..c447a6a 100644 +--- a/scipy/sparse/linalg/_propack/PROPACK/complex16/zreorth.F ++++ b/scipy/sparse/linalg/_propack/PROPACK/complex16/zreorth.F +@@ -2,8 +2,8 @@ c + c Rasmus Munk Larsen, Stanford University, 1999, 2004. + c + +- subroutine zreorth(n,k,V,ldv,vnew,normvnew,index,alpha,work, +- c iflag) ++ recursive subroutine zreorth(n,k,V,ldv,vnew,normvnew,index,alpha, ++ c work, iflag) + c + c Orthogonalize the N-vector VNEW against a subset of the columns of + c the N-by-K matrix V(1:N,1:K) using iterated classical or modified +@@ -103,7 +103,7 @@ c + c**************************************************************************** + c + +- subroutine zcgs(n,k,V,ldv,vnew,index,work) ++ recursive subroutine zcgs(n,k,V,ldv,vnew,index,work) + + c Block Gram-Schmidt orthogonalization: + c FOR i= 1:l +diff --git a/scipy/sparse/linalg/_propack/PROPACK/complex8/creorth.F b/scipy/sparse/linalg/_propack/PROPACK/complex8/creorth.F +index cd87247..e657a89 100644 +--- a/scipy/sparse/linalg/_propack/PROPACK/complex8/creorth.F ++++ b/scipy/sparse/linalg/_propack/PROPACK/complex8/creorth.F +@@ -2,8 +2,8 @@ c + c Rasmus Munk Larsen, Stanford University, 1999, 2004. + c + +- subroutine creorth(n,k,V,ldv,vnew,normvnew,index,alpha,work, +- c iflag) ++ recursive subroutine creorth(n,k,V,ldv,vnew,normvnew,index,alpha, ++ c work, iflag) + c + c Orthogonalize the N-vector VNEW against a subset of the columns of + c the N-by-K matrix V(1:N,1:K) using iterated classical or modified +@@ -103,7 +103,7 @@ c + c**************************************************************************** + c + +- subroutine ccgs(n,k,V,ldv,vnew,index,work) ++ recursive subroutine ccgs(n,k,V,ldv,vnew,index,work) + + c Block Gram-Schmidt orthogonalization: + c FOR i= 1:l +diff --git a/scipy/sparse/linalg/_propack/PROPACK/double/dreorth.F b/scipy/sparse/linalg/_propack/PROPACK/double/dreorth.F +index 841208a..fec923e 100644 +--- a/scipy/sparse/linalg/_propack/PROPACK/double/dreorth.F ++++ b/scipy/sparse/linalg/_propack/PROPACK/double/dreorth.F +@@ -2,8 +2,8 @@ c + c Rasmus Munk Larsen, Stanford University, 1999, 2004. + c + +- subroutine dreorth(n,k,V,ldv,vnew,normvnew,index,alpha,work, +- c iflag) ++ recursive subroutine dreorth(n,k,V,ldv,vnew,normvnew,index,alpha, ++ c work, iflag) + c + c Orthogonalize the N-vector VNEW against a subset of the columns of + c the N-by-K matrix V(1:N,1:K) using iterated classical or modified +@@ -103,7 +103,7 @@ c + c**************************************************************************** + c + +- subroutine dcgs(n,k,V,ldv,vnew,index,work) ++ recursive subroutine dcgs(n,k,V,ldv,vnew,index,work) + + c Block Gram-Schmidt orthogonalization: + c FOR i= 1:l +diff --git a/scipy/sparse/linalg/_propack/PROPACK/single/sreorth.F b/scipy/sparse/linalg/_propack/PROPACK/single/sreorth.F +index 644d404..61b6698 100644 +--- a/scipy/sparse/linalg/_propack/PROPACK/single/sreorth.F ++++ b/scipy/sparse/linalg/_propack/PROPACK/single/sreorth.F +@@ -2,8 +2,8 @@ c + c Rasmus Munk Larsen, Stanford University, 1999, 2004. + c + +- subroutine sreorth(n,k,V,ldv,vnew,normvnew,index,alpha,work, +- c iflag) ++ recursive subroutine sreorth(n,k,V,ldv,vnew,normvnew,index,alpha, ++ c work, iflag) + c + c Orthogonalize the N-vector VNEW against a subset of the columns of + c the N-by-K matrix V(1:N,1:K) using iterated classical or modified +@@ -103,7 +103,7 @@ c + c**************************************************************************** + c + +- subroutine scgs(n,k,V,ldv,vnew,index,work) ++ recursive subroutine scgs(n,k,V,ldv,vnew,index,work) + + c Block Gram-Schmidt orthogonalization: + c FOR i= 1:l +-- +2.34.1 + diff --git a/packages/scipy/patches/0002-int-to-string.patch b/packages/scipy/patches/0002-int-to-string.patch index ed0b980..46380e9 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/7] int to string +Subject: [PATCH 2/9] 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 744b29a..4fff1eb 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/7] gemm_ no const +Subject: [PATCH 3/9] 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 5bdcad0..91a5776 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/7] make int return values +Subject: [PATCH 4/9] 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 diff --git a/packages/scipy/patches/0005-Remove-test-modules-that-fails-to-build.patch b/packages/scipy/patches/0005-Remove-test-modules-that-fails-to-build.patch index 751b7a8..27dba8f 100644 --- a/packages/scipy/patches/0005-Remove-test-modules-that-fails-to-build.patch +++ b/packages/scipy/patches/0005-Remove-test-modules-that-fails-to-build.patch @@ -1,7 +1,7 @@ From e21f33695da3275ec81b5f94685f0e4ac92c9ad5 Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Mon, 30 Oct 2023 14:35:04 +0000 -Subject: [PATCH 5/7] Remove test modules that fails to build +Subject: [PATCH 5/9] Remove test modules that fails 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. diff --git a/packages/scipy/patches/0006-Fix-fitpack.patch b/packages/scipy/patches/0006-Fix-fitpack.patch index bf69a74..9764fbf 100644 --- a/packages/scipy/patches/0006-Fix-fitpack.patch +++ b/packages/scipy/patches/0006-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 6/7] Fix fitpack +Subject: [PATCH 6/9] Fix fitpack --- scipy/interpolate/fitpack/dblint.f | 9 ++++----- diff --git a/packages/scipy/patches/0007-Fix-gees-calls.patch b/packages/scipy/patches/0007-Fix-gees-calls.patch index d64eb30..9513a30 100644 --- a/packages/scipy/patches/0007-Fix-gees-calls.patch +++ b/packages/scipy/patches/0007-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 7/7] Fix gees calls +Subject: [PATCH 7/9] Fix gees calls --- scipy/linalg/flapack_gen.pyf.src | 8 ++++---- diff --git a/packages/scipy/patches/0008-MAINT-linalg-Remove-id_dist-Fortran-files.patch b/packages/scipy/patches/0008-MAINT-linalg-Remove-id_dist-Fortran-files.patch new file mode 100644 index 0000000..5855110 --- /dev/null +++ b/packages/scipy/patches/0008-MAINT-linalg-Remove-id_dist-Fortran-files.patch @@ -0,0 +1,21866 @@ +From ff20089a10768110934f803233471a7b4c67b068 Mon Sep 17 00:00:00 2001 +From: Ilhan Polat +Date: Tue, 23 Apr 2024 09:26:38 +0200 +Subject: [PATCH 8/9] 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 | 54 +- + 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, 2158 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 7613a464c..9c06dcb6c 100644 +--- a/mypy.ini ++++ b/mypy.ini +@@ -131,7 +131,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 +@@ -121,57 +121,14 @@ interpolative_module = custom_target('interpolative_module', + command: [py3, generate_f2pymod, '@INPUT@', '-o', '@OUTDIR@'] + ) + +-# 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', +- interpolative_module, +- ], ++# _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, +- fortran_args: [fortran_ignore_warnings, _suppress_all_warnings], + link_args: version_link_args, +- dependencies: [lapack, fortranobject_dep], + install: true, +- link_language: 'fortran', + subdir: 'scipy/linalg' + ) + +@@ -303,7 +260,6 @@ python_sources = [ + '_decomp_svd.py', + '_expm_frechet.py', + '_flinalg_py.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.34.1 + diff --git a/packages/scipy/patches/0009-Mark-mvndst-functions-recursive.patch b/packages/scipy/patches/0009-Mark-mvndst-functions-recursive.patch new file mode 100644 index 0000000..1984a1e --- /dev/null +++ b/packages/scipy/patches/0009-Mark-mvndst-functions-recursive.patch @@ -0,0 +1,38 @@ +From c11745d763407d9a2bb195a21e2a8afaf7635248 Mon Sep 17 00:00:00 2001 +From: Hood Chatham +Date: Sat, 6 Jul 2024 22:38:55 +0200 +Subject: [PATCH 9/9] 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/scipy-conftest.py b/packages/scipy/scipy-conftest.py new file mode 100644 index 0000000..4a01405 --- /dev/null +++ b/packages/scipy/scipy-conftest.py @@ -0,0 +1,263 @@ +import re + +import pytest + +xfail = pytest.mark.xfail +skip = pytest.mark.skip + +fp_exception_msg = ( + "no floating point exceptions, " + "see https://github.com/numpy/numpy/pull/21895#issuecomment-1311525881" +) +process_msg = "no process support" +thread_msg = "no thread support" +todo_signature_mismatch_msg = "TODO signature mismatch" +todo_memory_corruption_msgt = "TODO memory corruption" +todo_genuine_difference_msg = "TODO genuine difference to be investigated" + +tests_to_mark = [ + # scipy/_lib/tests + ( + "test__threadsafety.py::test_parallel_threads", + xfail, + thread_msg, + ), + ("test__threadsafety.py::test_parallel_threads", xfail, thread_msg), + ("test__util.py::test_pool", xfail, process_msg), + ("test__util.py::test_mapwrapper_parallel", xfail, process_msg), + ("test_ccallback.py::test_threadsafety", xfail, thread_msg), + ("test_import_cycles.py::test_modules_importable", xfail, process_msg), + ("test_import_cycles.py::test_public_modules_importable", xfail, process_msg), + # scipy/datasets/tests + ("test_data.py::TestDatasets", xfail, "TODO datasets not working right now"), + # scipy/fft/tests + ( + r"test_basic.py::TestFFT1D.test_dtypes\[float32-numpy\]", + xfail, + "TODO small floating point difference on the CI but not locally", + ), + ("test_basic.py::TestFFTThreadSafe", xfail, thread_msg), + ("test_basic.py::test_multiprocess", xfail, process_msg), + ("test_fft_function.py::test_fft_function", xfail, process_msg), + ("test_multithreading.py::test_threaded_same", xfail, thread_msg), + ( + "test_multithreading.py::test_mixed_threads_processes", + xfail, + thread_msg, + ), + # scipy/integrate tests + ("test__quad_vec.py::test_quad_vec_pool", xfail, process_msg), + ( + "test_quadpack.py.+TestCtypesQuad.test_ctypes.*", + xfail, + "Test relying on finding libm.so shared library", + ), + ( + "test_quadrature.py.+TestQMCQuad.test_basic", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_quadrature.py.+TestQMCQuad.test_sign", + xfail, + todo_genuine_difference_msg, + ), + # scipy/interpolate + ( + "test_fitpack.+test_kink", + xfail, + "TODO error not raised, maybe due to no floating point exception?", + ), + # scipy/io + ( + "test_mmio.py::.+fast_matrix_market", + xfail, + thread_msg, + ), + ( + "test_mmio.py::TestMMIOCoordinate.test_precision", + xfail, + thread_msg, + ), + ( + "test_paths.py::TestPaths.test_mmio_(read|write)", + xfail, + thread_msg, + ), + # scipy/linalg tests + ("test_blas.+test_complex_dotu", skip, todo_signature_mismatch_msg), + ("test_cython_blas.+complex", skip, todo_signature_mismatch_msg), + ("test_lapack.py.+larfg_larf", skip, todo_signature_mismatch_msg), + # scipy/ndimage/tests + ("test_filters.py::TestThreading", xfail, thread_msg), + # scipy/optimize/tests + ( + "test__differential_evolution.py::" + "TestDifferentialEvolutionSolver.test_immediate_updating", + xfail, + process_msg, + ), + ( + "test__differential_evolution.py::TestDifferentialEvolutionSolver.test_parallel", + xfail, + process_msg, + ), + ( + "test__shgo.py.+test_19_parallelization", + xfail, + process_msg, + ), + ( + "test__shgo.py.+", + xfail, + "Test failing on 32bit (skipped on win32)", + ), + ( + "test_linprog.py::TestLinprogSimplexNoPresolve.test_bounds_infeasible_2", + xfail, + "TODO no warnings emitted maybe due to no floating point exception?", + ), + ("test_minpack.py::TestFSolve.test_concurrent.+", xfail, process_msg), + ("test_minpack.py::TestLeastSq.test_concurrent+", xfail, process_msg), + ("test_optimize.py::test_cobyla_threadsafe", xfail, thread_msg), + ("test_optimize.py::TestBrute.test_workers", xfail, process_msg), + # scipy/signal/tests + ( + "test_signaltools.py::TestMedFilt.test_medfilt2d_parallel", + xfail, + thread_msg, + ), + # scipy/sparse/tests + ("test_arpack.py::test_parallel_threads", xfail, thread_msg), + ("test_array_api.py::test_sparse_dense_divide", xfail, fp_exception_msg), + # TODO remove when scipy 1.13 is packaged in Pyodide + ( + "test_base.py.+(COO|DIA|BSR).+multiple_ellipsis_slicing", + xfail, + "DeprecationWarning for scipy 1.13 not raised not important", + ), + ("test_linsolve.py::TestSplu.test_threads_parallel", xfail, thread_msg), + ("test_propack", skip, todo_signature_mismatch_msg), + ("test_sparsetools.py::test_threads", xfail, thread_msg), + # scipy/sparse/csgraph/tests + ("test_shortest_path.py::test_gh_17782_segfault", xfail, thread_msg), + # scipy/spatial/tests + ( + "test_kdtree.py::test_query_ball_point_multithreading", + xfail, + thread_msg, + ), + ("test_kdtree.py::test_ckdtree_parallel", xfail, thread_msg), + # scipy/special/tests + ( + "test_exponential_integrals.py::TestExp1.test_branch_cut", + xfail, + "TODO maybe float support since +0 and -0 difference", + ), + ( + "test_round.py::test_add_round_(up|down)", + xfail, + "TODO small floating point difference, maybe due to lack of floating point " + "support for controlling rounding, see " + "https://github.com/WebAssembly/design/issues/1384", + ), + ( + # This test is skipped for PyPy as well, maybe for a related reason?, + # see + # https://github.com/conda-forge/scipy-feedstock/pull/196#issuecomment-979317832 + "test_distributions.py::TestBeta.test_boost_eval_issue_14606", + skip, + "TODO C++ exception that causes a Pyodide fatal error", + ), + ( + "test_kdeoth.py::test_kde_[12]d", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_multivariate.py::TestMultivariateT.test_cdf_against_generic_integrators", + skip, + "TODO tplquad integration does not seem to converge", + ), + ( + "test_multivariate.py::TestCovariance.test_mvn_with_covariance_cdf.+Precision-size1", + xfail, + "TODO small floating point difference 6e-7 relative diff instead of 1e-7", + ), + ( + "test_multivariate.py::TestMultivariateNormal.test_logcdf_default_values", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_multivariate.py::TestMultivariateNormal.test_broadcasting", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_multivariate.py::TestMultivariateNormal.test_normal_1D", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_multivariate.py::TestMultivariateNormal.test_R_values", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_multivariate.py::TestMultivariateNormal.test_cdf_with_lower_limit", + xfail, + todo_genuine_difference_msg, + ), + ( + "test_multivariate.py::TestMultivariateT.test_cdf_against_multivariate_normal", + xfail, + todo_genuine_difference_msg, + ), + ("test_qmc.py::TestVDC.test_van_der_corput", xfail, thread_msg), + ("test_qmc.py::TestHalton.test_workers", xfail, thread_msg), + ("test_qmc.py::TestUtils.test_discrepancy_parallel", xfail, thread_msg), + ( + "test_qmc.py::TestMultivariateNormalQMC.test_validations", + xfail, + "TODO did not raise maybe no floating point exception support?", + ), + ( + "test_qmc.py::TestMultivariateNormalQMC.test_MultivariateNormalQMCDegenerate", + xfail, + todo_genuine_difference_msg, + ), + ("test_sampling.py::test_threading_behaviour", xfail, thread_msg), + ("test_stats.py::TestMGCStat.test_workers", xfail, process_msg), + ( + "test_stats.py::TestKSTwoSamples.testLargeBoth", + skip, + "TODO test taking > 5 minutes after scipy 1.10.1 update", + ), + ( + "test_stats.py::TestKSTwoSamples.test_some_code_paths", + xfail, + "TODO did not raise maybe no floating point exception support?", + ), + ( + "test_stats.py::TestGeometricStandardDeviation.test_raises_value_error", + xfail, + "TODO did not raise maybe no floating point exception support?", + ), + ( + "test_stats.py::TestBrunnerMunzel.test_brunnermunzel_normal_dist", + xfail, + fp_exception_msg, + ), +] + + +def pytest_collection_modifyitems(config, items): + for item in items: + path, line, name = item.reportinfo() + path = str(path) + full_name = f"{path}::{name}" + for pattern, mark, reason in tests_to_mark: + if re.search(pattern, full_name): + # print(full_name) + item.add_marker(mark(reason=reason)) diff --git a/packages/scipy/scipy-pytest.js b/packages/scipy/scipy-pytest.js new file mode 100644 index 0000000..6c3e54e --- /dev/null +++ b/packages/scipy/scipy-pytest.js @@ -0,0 +1,84 @@ +const { opendir } = require("node:fs/promises"); +const { loadPyodide } = require("pyodide"); + +async function main() { + let exit_code = 0; + try { + global.pyodide = await loadPyodide(); + let pyodide = global.pyodide; + const FS = pyodide.FS; + const NODEFS = FS.filesystems.NODEFS; + + let mountDir = "/mnt"; + pyodide.FS.mkdir(mountDir); + pyodide.FS.mount(pyodide.FS.filesystems.NODEFS, { root: "." }, mountDir); + + // Copy pytest-specific files dir if they exist + await pyodide.runPythonAsync(` + import shutil + import os + + pytest_filenames = ["/mnt/conftest.py", "/mnt/pytest.ini"] + + for filename in pytest_filenames: + if os.path.exists(filename): + shutil.copy(filename, ".") + + conftest_filename = "/mnt/conftest.py" + if os.path.exists(conftest_filename): + shutil.copy(conftest_filename, ".") + `); + + await pyodide.loadPackage(["micropip"]); + await pyodide.runPythonAsync(` + import micropip + + await micropip.install('scipy') + + try: + await micropip.install('scipy-tests') + except ValueError: + print('Hoping scipy tests are included in the scipy wheel') + + pkg_list = micropip.list() + print(pkg_list) + `); + + // XXX: some Fortran test modules are removed in Pyodide through a patch + // https://github.com/pyodide/pyodide/blob/main/packages/scipy/patches/0008-Remove-test-modules-that-fails-to-build.patch + // In order to avoid import errors during test discovery, we delete the + // problematic files. There seems to be no simpler way to do this with + // pytest, in particular --ignore-glob still imports the ignored file for + // some reason. + await pyodide.runPythonAsync(` + from pathlib import Path + + import scipy.io.tests + path = Path(scipy.io.tests.__file__).parent / "test_fortran.py" + os.unlink(path) + + import scipy.integrate.tests + path = Path(scipy.integrate.tests.__file__).parent / "test_odeint_jac.py" + os.unlink(path) + `); + + await pyodide.runPythonAsync( + "import micropip; micropip.install(['pytest', 'hypothesis', 'pooch', 'lzma'])", + ); + let pytest = pyodide.pyimport("pytest"); + let args = process.argv.slice(2); + console.log("pytest args:", args); + exit_code = pytest.main(pyodide.toPy(args)); + } catch (e) { + console.error(e); + // Arbitrary exit code here. I have seen this code reached instead of a + // Pyodide fatal error sometimes (I guess kind of similar to a random + // Python error). When there is a Pyodide fatal error we don't end up here + // somehow, and the exit code is 7 + exit_code = 66; + } finally { + process.exit(exit_code); + } +} + +main(); From b8589dc7eeafb583571a0cb5612b4a91a5f69eab Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Sun, 28 Jul 2024 16:45:53 +0900 Subject: [PATCH 2/5] Rearrange deps (#43) --- .github/workflows/build.yml | 2 +- environment.yml | 4 ---- requirements.txt | 5 +++++ 3 files changed, 6 insertions(+), 5 deletions(-) create mode 100644 requirements.txt diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index f5fc1e3..6881a26 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -259,7 +259,7 @@ jobs: - name: Install test dependencies run: | - pip install pytest pytest-pyodide pytest-httpserver auditwheel-emscripten pytest-asyncio + pip install -r requirements.txt - name: Run tests shell: bash -l {0} diff --git a/environment.yml b/environment.yml index 9c9d0ab..28d7c91 100644 --- a/environment.yml +++ b/environment.yml @@ -16,7 +16,3 @@ dependencies: - wget - setuptools - gfortran - - pip: - - pytest - - pytest-pyodide==0.58.1 - - pytest-httpserver diff --git a/requirements.txt b/requirements.txt new file mode 100644 index 0000000..b165a1a --- /dev/null +++ b/requirements.txt @@ -0,0 +1,5 @@ +pytest +pytest-pyodide==0.58.3 +pytest-httpserver +auditwheel-emscripten +pytest-asyncio From fc3797dc0ef3bed384e8913761dd0db9407c48c9 Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Sun, 28 Jul 2024 18:17:42 +0900 Subject: [PATCH 3/5] Update conftest.py to set global config (#44) Co-authored-by: pre-commit-ci[bot] <66853113+pre-commit-ci[bot]@users.noreply.github.com> --- conftest.py | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/conftest.py b/conftest.py index bb92bbb..c074467 100644 --- a/conftest.py +++ b/conftest.py @@ -1,9 +1,11 @@ """ Various common utilities for testing. """ + import re import pytest +from pytest_pyodide import get_global_config from pytest_pyodide.utils import package_is_built as _package_is_built @@ -80,6 +82,61 @@ def package_is_built(package_name): return _package_is_built(package_name, pytest.pyodide_dist_dir) +def set_configs(): + pytest_pyodide_config = get_global_config() + + pytest_pyodide_config.set_flags( + "chrome", + pytest_pyodide_config.get_flags("chrome") + + [ + "--enable-features=WebAssemblyExperimentalJSPI", + "--enable-experimental-webassembly-features", + ], + ) + + pytest_pyodide_config.set_flags( + "node", + pytest_pyodide_config.get_flags("node") + + ["--experimental-wasm-stack-switching"], + ) + + pytest_pyodide_config.set_load_pyodide_script( + "chrome", + """ + let pyodide = await loadPyodide({ + fullStdLib: false, + jsglobals : self, + enableRunUntilComplete: true, + }); + """, + ) + + pytest_pyodide_config.set_load_pyodide_script( + "node", + """ + const {readFileSync} = require("fs"); + let snap = readFileSync("snapshot.bin"); + snap = new Uint8Array(snap.buffer); + let pyodide = await loadPyodide({ + fullStdLib: false, + jsglobals: self, + _loadSnapshot: snap, + enableRunUntilComplete: true, + }); + """, + ) + + +set_configs() + + +only_node = pytest.mark.xfail_browsers( + chrome="node only", firefox="node only", safari="node only" +) +only_chrome = pytest.mark.xfail_browsers( + node="chrome only", firefox="chrome only", safari="chrome only" +) + requires_jspi = pytest.mark.xfail_browsers( firefox="requires jspi", safari="requires jspi" ) From 5157757f09b2961c93b208c2dac1c34d0f7aefdf Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Wed, 31 Jul 2024 22:49:07 +0900 Subject: [PATCH 4/5] Fix pytest and pygame-ce tests (#45) --- packages/pygame-ce/test_pygame.py | 6 ++++ packages/pytest/test_pytest.py | 52 ++++++++++++++++++++++--------- 2 files changed, 43 insertions(+), 15 deletions(-) diff --git a/packages/pygame-ce/test_pygame.py b/packages/pygame-ce/test_pygame.py index bd1c905..df8429e 100644 --- a/packages/pygame-ce/test_pygame.py +++ b/packages/pygame-ce/test_pygame.py @@ -1,6 +1,8 @@ import pytest from pytest_pyodide import run_in_pyodide +from conftest import package_is_built + @pytest.fixture(scope="function") def selenium_sdl(selenium_standalone): @@ -34,6 +36,10 @@ def test_keyboard_input(): See: https://github.com/pyodide/pyodide/issues/4805#issuecomment-2169077347 TODO: find a better way to test keyboard input """ + + if not package_is_built("pygame-ce"): + pytest.skip("pygame-ce is not built") + from pathlib import Path from auditwheel_emscripten import get_imports diff --git a/packages/pytest/test_pytest.py b/packages/pytest/test_pytest.py index 48e38a3..8ef5dfc 100644 --- a/packages/pytest/test_pytest.py +++ b/packages/pytest/test_pytest.py @@ -1,19 +1,41 @@ -def test_pytest(selenium): - # TODO: don't use numpy in this test as it's not necessarily installed. - selenium.load_package(["pytest", "numpy"]) +from pytest_pyodide import run_in_pyodide + + +@run_in_pyodide(packages=["pytest"]) +def do_test(selenium, contents): + from contextlib import redirect_stdout + from io import StringIO + from pathlib import Path + + import pytest + + Path("test_pytest.py").write_text(contents) - selenium.run( - """ - from pathlib import Path - import os - import numpy - import pytest + out = StringIO() + with redirect_stdout(out): + result = pytest.main(["test_pytest.py"]) + + assert result == 1 + + out.seek(0) + output = out.read() + assert "2 passed" in output, output + assert "1 failed" in output, output + assert "1 warning" in output, output + assert "This is a warning" in output, output + + +def test_pytest(selenium): + contents = """ +def test_success(): + assert 1 == 1 - base_dir = Path(numpy.__file__).parent / "core" / "tests" - """ - ) +def test_warning(): + import warnings + warnings.warn("This is a warning") - selenium.run("pytest.main([str(base_dir / 'test_api.py')])") +def test_fail(): + assert 1 == 2 +""" - logs = "\n".join(selenium.logs) - assert "INTERNALERROR" not in logs + do_test(selenium, contents) From 381c50df588ece46334989570a77acf29ecc6014 Mon Sep 17 00:00:00 2001 From: Gyeongjae Choi Date: Sat, 3 Aug 2024 13:58:47 +0900 Subject: [PATCH 5/5] CI Remove top-level directory from the release archive (#46) --- .github/workflows/build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 6881a26..186ed65 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -193,7 +193,7 @@ jobs: - name: Compress build artifacts run: | - tar -czvf packages.tar.gz repodata + tar -czvf packages.tar.gz -C repodata . - name: Release uses: softprops/action-gh-release@v1