├── .gitignore ├── Makefile ├── README.md ├── bin └── .gitignore ├── doc ├── Makefile ├── api.rst ├── conf.py ├── index.rst ├── install.rst ├── intro.rst ├── make.bat └── tutorial.rst ├── examples └── driver.py ├── external └── id_dist │ ├── Makefile │ ├── README.txt │ ├── development │ ├── RUNME.sh │ ├── copy_final.sh │ ├── dfft.f │ ├── id_rand.f │ ├── id_rtrans.f │ ├── idd_a_test.f │ ├── idd_frm.f │ ├── idd_house.f │ ├── idd_id.f │ ├── idd_id2svd.f │ ├── idd_qrpiv.f │ ├── idd_r_test.f │ ├── idd_sfft.f │ ├── idd_snorm.f │ ├── idd_svd.f │ ├── iddp_aid.f │ ├── iddp_asvd.f │ ├── iddp_rid.f │ ├── iddp_rsvd.f │ ├── iddr_aid.f │ ├── iddr_asvd.f │ ├── iddr_rid.f │ ├── iddr_rsvd.f │ ├── idz_a_test.f │ ├── idz_frm.f │ ├── idz_house.f │ ├── idz_id.f │ ├── idz_id2svd.f │ ├── idz_qrpiv.f │ ├── idz_r_test.f │ ├── idz_sfft.f │ ├── idz_snorm.f │ ├── idz_svd.f │ ├── idzp_aid.f │ ├── idzp_asvd.f │ ├── idzp_rid.f │ ├── idzp_rsvd.f │ ├── idzr_aid.f │ ├── idzr_asvd.f │ ├── idzr_rid.f │ ├── idzr_rsvd.f │ ├── make_src.sh │ ├── make_test.sh │ └── prini.f │ ├── doc │ ├── doc.bib │ ├── doc.pdf │ ├── doc.ps │ ├── doc.tex │ └── supertabular.sty │ ├── size.txt │ ├── src │ ├── dfft.f │ ├── id_rand.f │ ├── id_rtrans.f │ ├── idd_frm.f │ ├── idd_house.f │ ├── idd_id.f │ ├── idd_id2svd.f │ ├── idd_qrpiv.f │ ├── idd_sfft.f │ ├── idd_snorm.f │ ├── idd_svd.f │ ├── iddp_aid.f │ ├── iddp_asvd.f │ ├── iddp_rid.f │ ├── iddp_rsvd.f │ ├── iddr_aid.f │ ├── iddr_asvd.f │ ├── iddr_rid.f │ ├── iddr_rsvd.f │ ├── idz_frm.f │ ├── idz_house.f │ ├── idz_id.f │ ├── idz_id2svd.f │ ├── idz_qrpiv.f │ ├── idz_sfft.f │ ├── idz_snorm.f │ ├── idz_svd.f │ ├── idzp_aid.f │ ├── idzp_asvd.f │ ├── idzp_rid.f │ ├── idzp_rsvd.f │ ├── idzr_aid.f │ ├── idzr_asvd.f │ ├── idzr_rid.f │ ├── idzr_rsvd.f │ └── prini.f │ ├── test │ ├── id_rand_test.f │ ├── id_rtrans_test.f │ ├── idd_a_test.f │ ├── idd_frm_test.f │ ├── idd_house_test.f │ ├── idd_id2svd_test.f │ ├── idd_id_test.f │ ├── idd_qrpiv_test.f │ ├── idd_r_test.f │ ├── idd_sfft_test.f │ ├── idd_snorm_test.f │ ├── idd_svd_test.f │ ├── iddp_aid_test.f │ ├── iddp_asvd_test.f │ ├── iddp_rid_test.f │ ├── iddp_rsvd_test.f │ ├── iddr_aid_test.f │ ├── iddr_asvd_test.f │ ├── iddr_rid_test.f │ ├── iddr_rsvd_test.f │ ├── idz_a_test.f │ ├── idz_frm_test.f │ ├── idz_house_test.f │ ├── idz_id2svd_test.f │ ├── idz_id_test.f │ ├── idz_qrpiv_test.f │ ├── idz_r_test.f │ ├── idz_sfft_test.f │ ├── idz_snorm_test.f │ ├── idz_svd_test.f │ ├── idzp_aid_test.f │ ├── idzp_asvd_test.f │ ├── idzp_rid_test.f │ ├── idzp_rsvd_test.f │ ├── idzr_aid_test.f │ ├── idzr_asvd_test.f │ ├── idzr_rid_test.f │ └── idzr_rsvd_test.f │ └── tmp │ └── .gitignore ├── python └── pymatrixid │ ├── __init__.py │ └── backend.py └── src └── id_dist.pyf /.gitignore: -------------------------------------------------------------------------------- 1 | *.a 2 | *.so 3 | *.pyc 4 | doc/_build 5 | external/id_dist/bin 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | LIB = pymatrixid 2 | ID_LIB = id_dist 3 | F2PY = f2py3 4 | F2PYFLAGS = --fcompiler=gnu95 --link-lapack_opt 5 | PYTHON = python 6 | 7 | SRC = src 8 | BIN = bin 9 | PYTHON = python 10 | DOC = doc 11 | EXAMPLES = examples 12 | ID_DIR = external/$(ID_LIB) 13 | ID_SRC = $(ID_DIR)/src 14 | 15 | F2PY_EXT = $(shell python3-config --extension-suffix) 16 | ID_PYLIB = $(ID_LIB)$(F2PY_EXT) 17 | 18 | vpath %.pyf $(SRC) 19 | vpath %.so $(PYTHON) 20 | 21 | .PHONY: all python id_dist doc clean clean_python clean_id_dist clean_doc rebuild help 22 | 23 | all: python 24 | 25 | $(ID_PYLIB): $(ID_LIB).pyf 26 | $(F2PY) -c $< $(F2PYFLAGS) $(ID_SRC)/*.f 27 | mv $(ID_PYLIB) $(BIN) 28 | cd $(PYTHON) ; ln -fs ../$(BIN)/$(ID_PYLIB) 29 | 30 | python: $(ID_PYLIB) 31 | 32 | id_dist: 33 | cd $(ID_DIR) ; make 34 | 35 | doc: python 36 | cd $(DOC) ; make html ; make latexpdf 37 | 38 | driver: python 39 | cd $(EXAMPLES) ; python3 driver.py 40 | 41 | clean: clean_python clean_id_dist clean_doc clean_driver 42 | 43 | clean_python: 44 | cd $(BIN) ; rm -f $(ID_PYLIB) 45 | cd $(PYTHON) ; rm -f $(ID_PYLIB) 46 | cd $(PYTHON)/$(LIB) ; rm -rf __pycache__ 47 | 48 | clean_id_dist: 49 | cd $(ID_DIR) ; make clean 50 | 51 | clean_doc: 52 | cd $(DOC) ; make clean 53 | 54 | clean_driver: 55 | cd $(EXAMPLES) ; 56 | 57 | rebuild: clean all 58 | 59 | help: 60 | @echo "Please use \`make ' where is one of" 61 | @echo " all to make the Python wrapper" 62 | @echo " python to make the Python wrapper" 63 | @echo " id_dist to make the Fortran ID library" 64 | @echo " doc to make HTML and PDF documentation" 65 | @echo " driver to make the Python driver program" 66 | @echo " clean to remove all compiled objects" 67 | @echo " clean_python to remove all compiled Python objects" 68 | @echo " clean_doc to remove all compiled documentation" 69 | @echo " clean_driver to remove all compiled driver executables" 70 | @echo " rebuild to clean and rebuild all libraries" 71 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | PyMatrixID 2 | ========== 3 | 4 | An interpolative decomposition (ID) of a matrix is a factorization as a product of a skeleton matrix consisting of a subset of columns and an interpolation matrix containing the identity. Like the singular value decomposition (SVD), the ID is a powerful approximation tool. The principal advantages of using an ID instead of an SVD are that: 5 | 6 | - it is cheaper to construct; 7 | - it preserves the matrix structure; and 8 | - it is more efficient to compute with in light of the structure of the interpolation matrix. 9 | 10 | The ID software package by Martinsson, Rokhlin, Shkolnisky, and Tygert is a Fortran library to compute IDs using various algorithms, including the deterministic pivoted QR approach and more recent randomized methods. PyMatrixID is a Python wrapper for this package that exposes its functionality in a more convenient manner. Note that PyMatrixID does not add any functionality beyond that of organizing a simpler and more consistent interface. 11 | 12 | PyMatrixID is freely available under the BSD license; for alternate licenses, please contact the author. 13 | 14 | **Note**: PyMatrixID has been merged into SciPy 0.13 (in a slightly modified form) as ``scipy.linalg.interpolative`` by Andreas Klöckner and Pauli Virtanen. It is highly recommended to henceforth use that package instead. -------------------------------------------------------------------------------- /bin/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/klho/PyMatrixID/3bdc86a36efd0628c031ae7fb31acaa810e801c3/bin/.gitignore -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line. 5 | SPHINXOPTS = 6 | SPHINXBUILD = sphinx-build 7 | PAPER = 8 | BUILDDIR = _build 9 | 10 | # Internal variables. 11 | PAPEROPT_a4 = -D latex_paper_size=a4 12 | PAPEROPT_letter = -D latex_paper_size=letter 13 | ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . 14 | # the i18n builder cannot share the environment and doctrees with the others 15 | I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . 16 | 17 | .PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest gettext 18 | 19 | help: 20 | @echo "Please use \`make ' where is one of" 21 | @echo " html to make standalone HTML files" 22 | @echo " dirhtml to make HTML files named index.html in directories" 23 | @echo " singlehtml to make a single large HTML file" 24 | @echo " pickle to make pickle files" 25 | @echo " json to make JSON files" 26 | @echo " htmlhelp to make HTML files and a HTML help project" 27 | @echo " qthelp to make HTML files and a qthelp project" 28 | @echo " devhelp to make HTML files and a Devhelp project" 29 | @echo " epub to make an epub" 30 | @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" 31 | @echo " latexpdf to make LaTeX files and run them through pdflatex" 32 | @echo " text to make text files" 33 | @echo " man to make manual pages" 34 | @echo " texinfo to make Texinfo files" 35 | @echo " info to make Texinfo files and run them through makeinfo" 36 | @echo " gettext to make PO message catalogs" 37 | @echo " changes to make an overview of all changed/added/deprecated items" 38 | @echo " linkcheck to check all external links for integrity" 39 | @echo " doctest to run all doctests embedded in the documentation (if enabled)" 40 | 41 | clean: 42 | -rm -rf $(BUILDDIR)/* 43 | 44 | html: 45 | $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html 46 | @echo 47 | @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." 48 | 49 | dirhtml: 50 | $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml 51 | @echo 52 | @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." 53 | 54 | singlehtml: 55 | $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml 56 | @echo 57 | @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." 58 | 59 | pickle: 60 | $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle 61 | @echo 62 | @echo "Build finished; now you can process the pickle files." 63 | 64 | json: 65 | $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json 66 | @echo 67 | @echo "Build finished; now you can process the JSON files." 68 | 69 | htmlhelp: 70 | $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp 71 | @echo 72 | @echo "Build finished; now you can run HTML Help Workshop with the" \ 73 | ".hhp project file in $(BUILDDIR)/htmlhelp." 74 | 75 | qthelp: 76 | $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp 77 | @echo 78 | @echo "Build finished; now you can run "qcollectiongenerator" with the" \ 79 | ".qhcp project file in $(BUILDDIR)/qthelp, like this:" 80 | @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/PyMatrixID.qhcp" 81 | @echo "To view the help file:" 82 | @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/PyMatrixID.qhc" 83 | 84 | devhelp: 85 | $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp 86 | @echo 87 | @echo "Build finished." 88 | @echo "To view the help file:" 89 | @echo "# mkdir -p $$HOME/.local/share/devhelp/PyMatrixID" 90 | @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/PyMatrixID" 91 | @echo "# devhelp" 92 | 93 | epub: 94 | $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub 95 | @echo 96 | @echo "Build finished. The epub file is in $(BUILDDIR)/epub." 97 | 98 | latex: 99 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 100 | @echo 101 | @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." 102 | @echo "Run \`make' in that directory to run these through (pdf)latex" \ 103 | "(use \`make latexpdf' here to do that automatically)." 104 | 105 | latexpdf: 106 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 107 | @echo "Running LaTeX files through pdflatex..." 108 | $(MAKE) -C $(BUILDDIR)/latex all-pdf 109 | @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." 110 | 111 | text: 112 | $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text 113 | @echo 114 | @echo "Build finished. The text files are in $(BUILDDIR)/text." 115 | 116 | man: 117 | $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man 118 | @echo 119 | @echo "Build finished. The manual pages are in $(BUILDDIR)/man." 120 | 121 | texinfo: 122 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo 123 | @echo 124 | @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." 125 | @echo "Run \`make' in that directory to run these through makeinfo" \ 126 | "(use \`make info' here to do that automatically)." 127 | 128 | info: 129 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo 130 | @echo "Running Texinfo files through makeinfo..." 131 | make -C $(BUILDDIR)/texinfo info 132 | @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." 133 | 134 | gettext: 135 | $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale 136 | @echo 137 | @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." 138 | 139 | changes: 140 | $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes 141 | @echo 142 | @echo "The overview file is in $(BUILDDIR)/changes." 143 | 144 | linkcheck: 145 | $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck 146 | @echo 147 | @echo "Link check complete; look for any errors in the above output " \ 148 | "or in $(BUILDDIR)/linkcheck/output.txt." 149 | 150 | doctest: 151 | $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest 152 | @echo "Testing of doctests in the sources finished, look at the " \ 153 | "results in $(BUILDDIR)/doctest/output.txt." 154 | -------------------------------------------------------------------------------- /doc/api.rst: -------------------------------------------------------------------------------- 1 | Python API 2 | ========== 3 | 4 | This section provides the auto-generated API for the Python modules :mod:`pymatrixid` and :mod:`pymatrixid.backend`. The functions in :mod:`pymatrixid.backend` are wrappers for the routines of the same name in the Fortran ID software package; for details, please consult the Fortran source code (in ``external/id_dist/src``). 5 | 6 | pymatrixid 7 | ---------- 8 | 9 | .. automodule:: pymatrixid 10 | :members: 11 | :undoc-members: 12 | :show-inheritance: 13 | 14 | pymatrixid.backend 15 | ------------------ 16 | 17 | .. automodule:: pymatrixid.backend 18 | :members: 19 | :undoc-members: 20 | :show-inheritance: -------------------------------------------------------------------------------- /doc/index.rst: -------------------------------------------------------------------------------- 1 | .. PyMatrixID documentation master file, created by 2 | sphinx-quickstart on Fri Feb 1 23:17:57 2013. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Welcome to PyMatrixID's documentation! 7 | ====================================== 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | intro 15 | install 16 | tutorial 17 | api 18 | 19 | 20 | Indices and tables 21 | ================== 22 | 23 | * :ref:`genindex` 24 | * :ref:`modindex` 25 | * :ref:`search` 26 | 27 | -------------------------------------------------------------------------------- /doc/install.rst: -------------------------------------------------------------------------------- 1 | Installing 2 | ========== 3 | 4 | This section describes how to compile and install PyMatrixID on Unix-like systems. Primary prerequisites include `Git `_, `GNU Make `_, a Fortran compiler such as `GFortran `_, `F2PY `_, `Python `_, and `NumPy `_. Secondary prerequisites include `Sphinx `_ and `LaTeX `_ for the documentation. 5 | 6 | PyMatrixID has only been tested using GFortran; the use of all other compilers should be considered "at your own risk" (though they should really be fine). 7 | 8 | Code repository 9 | --------------- 10 | 11 | All source files for PyMatrixID (including those for this documentation) are available at https://github.com/klho/PyMatrixID. To download PyMatrixID using Git, type the following command at the shell prompt:: 12 | 13 | $ git clone https://github.com/klho/PyMatrixID /path/to/local/repository/ 14 | 15 | Compiling 16 | --------- 17 | 18 | There are several targets available to compile, namely: 19 | 20 | - the Python wrapper; 21 | 22 | - the ID package; and 23 | 24 | - this documentation. 25 | 26 | To see all available targets, switch the working directory to the root of the local repository and type:: 27 | 28 | $ make help 29 | 30 | Hopefully the instructions are self-explanatory; for more explicit directions, please see below. Before beginning, view and edit the file ``Makefile`` to ensure that all options are properly set for your system. In particular, if you will not be using GFortran, be sure to set an alternate compiler as appropriate. 31 | 32 | To compile the Python wrapper, type:: 33 | 34 | $ make 35 | 36 | or:: 37 | 38 | $ make all 39 | 40 | or:: 41 | 42 | $ make python 43 | 44 | This creates the F2PY-ed library ``bin/id_dist.so``. 45 | 46 | To compile the ID package, type:: 47 | 48 | $ make id_dist 49 | 50 | It is not necessary to compile the ID package in order to use the Python wrapper; the required binaries are created automatically by F2PY. However, compiling the ID package itself may be useful, for example, to test the library independently. The ID package is located in the directory ``external/id_dist``. 51 | 52 | To compile the documentation files, type:: 53 | 54 | $ make doc 55 | 56 | Output HTML and PDF files are placed in the directory ``doc``. 57 | 58 | Driver program 59 | -------------- 60 | 61 | PyMatrixID also contains a driver program to demonstrate its use. To run the driver, type:: 62 | 63 | $ make driver 64 | 65 | The driver program is discussed in more detail in :doc:`tutorial`. -------------------------------------------------------------------------------- /doc/intro.rst: -------------------------------------------------------------------------------- 1 | Introduction 2 | ============ 3 | 4 | An interpolative decomposition (ID) of a matrix :math:`A \in \mathbb{C}^{m \times n}` of rank :math:`k \leq \min \{ m, n \}` is a factorization 5 | 6 | .. math:: 7 | A \Pi = 8 | \begin{bmatrix} 9 | A \Pi_{1} & A \Pi_{2} 10 | \end{bmatrix} = 11 | A \Pi_{1} 12 | \begin{bmatrix} 13 | I & T 14 | \end{bmatrix}, 15 | 16 | where :math:`\Pi = [\Pi_{1}, \Pi_{2}]` is a permutation matrix with :math:`\Pi_{1} \in \{ 0, 1 \}^{n \times k}`, i.e., :math:`A \Pi_{2} = A \Pi_{1} T`. This can equivalently be written as :math:`A = BP`, where :math:`B = A \Pi_{1}` and :math:`P = [I, T] \Pi^{\mathsf{T}}` are the *skeleton* and *interpolation matrices*, respectively. 17 | 18 | If :math:`A` does not have exact rank :math:`k`, then there exists an approximation in the form of an ID such that :math:`A = BP + E`, where :math:`\| E \| \sim \sigma_{k + 1}` is on the order of the :math:`(k + 1)`-th largest singular value of :math:`A`. Note that :math:`\sigma_{k + 1}` is the best possible error for a rank-:math:`k` approximation and, in fact, is achieved by the singular value decomposition (SVD) :math:`A \approx U S V^{*}`, where :math:`U \in \mathbb{C}^{m \times k}` and :math:`V \in \mathbb{C}^{n \times k}` have orthonormal columns and :math:`S = \mathop{\mathrm{diag}} (\sigma_{i}) \in \mathbb{C}^{k \times k}` is diagonal with nonnegative entries. The principal advantages of using an ID over an SVD are that: 19 | 20 | - it is cheaper to construct; 21 | - it preserves the structure of :math:`A`; and 22 | - it is more efficient to compute with in light of the identity submatrix of :math:`P`. 23 | 24 | .. note:: 25 | PyMatrixID has been merged into SciPy 0.13 (in a slightly modified form) as :mod:`scipy.linalg.interpolative` by Andreas Klöckner and Pauli Virtanen. It is highly recommended to henceforth use that package instead. 26 | 27 | Overview 28 | -------- 29 | 30 | The ID software package [4]_ by Martinsson, Rokhlin, Shkolnisky, and Tygert is a Fortran library to compute IDs using various algorithms, including the deterministic pivoted QR approach of [1]_ and the more recent randomized methods described in [2]_, [3]_, and [5]_. PyMatrixID is a Python wrapper for this package that exposes its functionality in a more convenient manner. Note that PyMatrixID does not add any functionality beyond that of organizing a simpler and more consistent interface. 31 | 32 | We advise the user to consult also the documentation for the ID package, which is included in full as part of PyMatrixID. 33 | 34 | Licensing and availability 35 | -------------------------- 36 | 37 | PyMatrixID is freely available under the `BSD license `_ and can be downloaded at https://github.com/klho/PyMatrixID. To request alternate licenses, please contact the author. 38 | 39 | PyMatrixID also distributes the ID software package, which is likewise released under the BSD license. 40 | 41 | References 42 | ---------- 43 | 44 | .. [1] H.\ Cheng, Z. Gimbutas, P.G. Martinsson, V. Rokhlin. On the compression of low rank matrices. `SIAM J. Sci. Comput.` 26 (4): 1389--1404, 2005. `doi:10.1137/030602678 `_. 45 | 46 | .. [2] N.\ Halko, P.G. Martinsson, J.A. Tropp. Finding structure with randomness: Probabilistic algorithms for constructing approximate matrix decompositions. `SIAM Rev.` 53 (2): 217--288, 2011. `doi:10.1137/090771806 `_. 47 | 48 | .. [3] E.\ Liberty, F. Woolfe, P.G. Martinsson, V. Rokhlin, M. Tygert. Randomized algorithms for the low-rank approximation of matrices. `Proc. Natl. Acad. Sci. USA` 104 (51): 20167--20172, 2007. `doi:10.1073/pnas.0709640104 `_. 49 | 50 | .. [4] P.G.\ Martinsson, V. Rokhlin, M. Tygert. A randomized algorithm for the decomposition of matrices. `Appl. Comput. Harmon. Anal.` 30 (1): 47--68, 2011. `doi:10.1016/j.acha.2010.02.003 `_. 51 | 52 | .. [5] P.G.\ Martinsson, V. Rokhlin, Y. Shkolnisky, M. Tygert. ID: a software package for low-rank approximation of matrices via interpolative decompositions, version 0.3. http://cims.nyu.edu/~tygert/id_doc.pdf. 53 | 54 | .. [6] F.\ Woolfe, E. Liberty, V. Rokhlin, M. Tygert. A fast randomized algorithm for the approximation of matrices. `Appl. Comput. Harmon. Anal.` 25 (3): 335--366, 2008. `doi:10.1016/j.acha.2007.12.002 `_. -------------------------------------------------------------------------------- /doc/make.bat: -------------------------------------------------------------------------------- 1 | @ECHO OFF 2 | 3 | REM Command file for Sphinx documentation 4 | 5 | if "%SPHINXBUILD%" == "" ( 6 | set SPHINXBUILD=sphinx-build 7 | ) 8 | set BUILDDIR=_build 9 | set ALLSPHINXOPTS=-d %BUILDDIR%/doctrees %SPHINXOPTS% . 10 | set I18NSPHINXOPTS=%SPHINXOPTS% . 11 | if NOT "%PAPER%" == "" ( 12 | set ALLSPHINXOPTS=-D latex_paper_size=%PAPER% %ALLSPHINXOPTS% 13 | set I18NSPHINXOPTS=-D latex_paper_size=%PAPER% %I18NSPHINXOPTS% 14 | ) 15 | 16 | if "%1" == "" goto help 17 | 18 | if "%1" == "help" ( 19 | :help 20 | echo.Please use `make ^` where ^ is one of 21 | echo. html to make standalone HTML files 22 | echo. dirhtml to make HTML files named index.html in directories 23 | echo. singlehtml to make a single large HTML file 24 | echo. pickle to make pickle files 25 | echo. json to make JSON files 26 | echo. htmlhelp to make HTML files and a HTML help project 27 | echo. qthelp to make HTML files and a qthelp project 28 | echo. devhelp to make HTML files and a Devhelp project 29 | echo. epub to make an epub 30 | echo. latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter 31 | echo. text to make text files 32 | echo. man to make manual pages 33 | echo. texinfo to make Texinfo files 34 | echo. gettext to make PO message catalogs 35 | echo. changes to make an overview over all changed/added/deprecated items 36 | echo. linkcheck to check all external links for integrity 37 | echo. doctest to run all doctests embedded in the documentation if enabled 38 | goto end 39 | ) 40 | 41 | if "%1" == "clean" ( 42 | for /d %%i in (%BUILDDIR%\*) do rmdir /q /s %%i 43 | del /q /s %BUILDDIR%\* 44 | goto end 45 | ) 46 | 47 | if "%1" == "html" ( 48 | %SPHINXBUILD% -b html %ALLSPHINXOPTS% %BUILDDIR%/html 49 | if errorlevel 1 exit /b 1 50 | echo. 51 | echo.Build finished. The HTML pages are in %BUILDDIR%/html. 52 | goto end 53 | ) 54 | 55 | if "%1" == "dirhtml" ( 56 | %SPHINXBUILD% -b dirhtml %ALLSPHINXOPTS% %BUILDDIR%/dirhtml 57 | if errorlevel 1 exit /b 1 58 | echo. 59 | echo.Build finished. The HTML pages are in %BUILDDIR%/dirhtml. 60 | goto end 61 | ) 62 | 63 | if "%1" == "singlehtml" ( 64 | %SPHINXBUILD% -b singlehtml %ALLSPHINXOPTS% %BUILDDIR%/singlehtml 65 | if errorlevel 1 exit /b 1 66 | echo. 67 | echo.Build finished. The HTML pages are in %BUILDDIR%/singlehtml. 68 | goto end 69 | ) 70 | 71 | if "%1" == "pickle" ( 72 | %SPHINXBUILD% -b pickle %ALLSPHINXOPTS% %BUILDDIR%/pickle 73 | if errorlevel 1 exit /b 1 74 | echo. 75 | echo.Build finished; now you can process the pickle files. 76 | goto end 77 | ) 78 | 79 | if "%1" == "json" ( 80 | %SPHINXBUILD% -b json %ALLSPHINXOPTS% %BUILDDIR%/json 81 | if errorlevel 1 exit /b 1 82 | echo. 83 | echo.Build finished; now you can process the JSON files. 84 | goto end 85 | ) 86 | 87 | if "%1" == "htmlhelp" ( 88 | %SPHINXBUILD% -b htmlhelp %ALLSPHINXOPTS% %BUILDDIR%/htmlhelp 89 | if errorlevel 1 exit /b 1 90 | echo. 91 | echo.Build finished; now you can run HTML Help Workshop with the ^ 92 | .hhp project file in %BUILDDIR%/htmlhelp. 93 | goto end 94 | ) 95 | 96 | if "%1" == "qthelp" ( 97 | %SPHINXBUILD% -b qthelp %ALLSPHINXOPTS% %BUILDDIR%/qthelp 98 | if errorlevel 1 exit /b 1 99 | echo. 100 | echo.Build finished; now you can run "qcollectiongenerator" with the ^ 101 | .qhcp project file in %BUILDDIR%/qthelp, like this: 102 | echo.^> qcollectiongenerator %BUILDDIR%\qthelp\PyMatrixID.qhcp 103 | echo.To view the help file: 104 | echo.^> assistant -collectionFile %BUILDDIR%\qthelp\PyMatrixID.ghc 105 | goto end 106 | ) 107 | 108 | if "%1" == "devhelp" ( 109 | %SPHINXBUILD% -b devhelp %ALLSPHINXOPTS% %BUILDDIR%/devhelp 110 | if errorlevel 1 exit /b 1 111 | echo. 112 | echo.Build finished. 113 | goto end 114 | ) 115 | 116 | if "%1" == "epub" ( 117 | %SPHINXBUILD% -b epub %ALLSPHINXOPTS% %BUILDDIR%/epub 118 | if errorlevel 1 exit /b 1 119 | echo. 120 | echo.Build finished. The epub file is in %BUILDDIR%/epub. 121 | goto end 122 | ) 123 | 124 | if "%1" == "latex" ( 125 | %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex 126 | if errorlevel 1 exit /b 1 127 | echo. 128 | echo.Build finished; the LaTeX files are in %BUILDDIR%/latex. 129 | goto end 130 | ) 131 | 132 | if "%1" == "text" ( 133 | %SPHINXBUILD% -b text %ALLSPHINXOPTS% %BUILDDIR%/text 134 | if errorlevel 1 exit /b 1 135 | echo. 136 | echo.Build finished. The text files are in %BUILDDIR%/text. 137 | goto end 138 | ) 139 | 140 | if "%1" == "man" ( 141 | %SPHINXBUILD% -b man %ALLSPHINXOPTS% %BUILDDIR%/man 142 | if errorlevel 1 exit /b 1 143 | echo. 144 | echo.Build finished. The manual pages are in %BUILDDIR%/man. 145 | goto end 146 | ) 147 | 148 | if "%1" == "texinfo" ( 149 | %SPHINXBUILD% -b texinfo %ALLSPHINXOPTS% %BUILDDIR%/texinfo 150 | if errorlevel 1 exit /b 1 151 | echo. 152 | echo.Build finished. The Texinfo files are in %BUILDDIR%/texinfo. 153 | goto end 154 | ) 155 | 156 | if "%1" == "gettext" ( 157 | %SPHINXBUILD% -b gettext %I18NSPHINXOPTS% %BUILDDIR%/locale 158 | if errorlevel 1 exit /b 1 159 | echo. 160 | echo.Build finished. The message catalogs are in %BUILDDIR%/locale. 161 | goto end 162 | ) 163 | 164 | if "%1" == "changes" ( 165 | %SPHINXBUILD% -b changes %ALLSPHINXOPTS% %BUILDDIR%/changes 166 | if errorlevel 1 exit /b 1 167 | echo. 168 | echo.The overview file is in %BUILDDIR%/changes. 169 | goto end 170 | ) 171 | 172 | if "%1" == "linkcheck" ( 173 | %SPHINXBUILD% -b linkcheck %ALLSPHINXOPTS% %BUILDDIR%/linkcheck 174 | if errorlevel 1 exit /b 1 175 | echo. 176 | echo.Link check complete; look for any errors in the above output ^ 177 | or in %BUILDDIR%/linkcheck/output.txt. 178 | goto end 179 | ) 180 | 181 | if "%1" == "doctest" ( 182 | %SPHINXBUILD% -b doctest %ALLSPHINXOPTS% %BUILDDIR%/doctest 183 | if errorlevel 1 exit /b 1 184 | echo. 185 | echo.Testing of doctests in the sources finished, look at the ^ 186 | results in %BUILDDIR%/doctest/output.txt. 187 | goto end 188 | ) 189 | 190 | :end 191 | -------------------------------------------------------------------------------- /examples/driver.py: -------------------------------------------------------------------------------- 1 | #******************************************************************************* 2 | # Copyright (C) 2013 Kenneth L. Ho 3 | # 4 | # Redistribution and use in source and binary forms, with or without 5 | # modification, are permitted provided that the following conditions are met: 6 | # 7 | # Redistributions of source code must retain the above copyright notice, this 8 | # list of conditions and the following disclaimer. Redistributions in binary 9 | # form must reproduce the above copyright notice, this list of conditions and 10 | # the following disclaimer in the documentation and/or other materials 11 | # provided with the distribution. 12 | # 13 | # None of the names of the copyright holders may be used to endorse or promote 14 | # products derived from this software without specific prior written 15 | # permission. 16 | # 17 | # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 21 | # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 22 | # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 23 | # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 24 | # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 25 | # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 26 | # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 27 | # POSSIBILITY OF SUCH DAMAGE. 28 | #******************************************************************************* 29 | 30 | import sys 31 | sys.path.append('../python/') 32 | 33 | import pymatrixid 34 | import numpy as np 35 | from scipy.linalg import hilbert 36 | from scipy.sparse.linalg import aslinearoperator 37 | import time 38 | 39 | if __name__ == '__main__': 40 | """ 41 | Test ID routines on a Hilbert matrix. 42 | """ 43 | # set parameters 44 | n = 1000 45 | eps = 1e-12 46 | 47 | # construct Hilbert matrix 48 | A = hilbert(n) 49 | 50 | # find rank 51 | S = np.linalg.svd(A, compute_uv=False) 52 | try: rank = np.nonzero(S < eps)[0][0] 53 | except: rank = n 54 | 55 | # print input summary 56 | print("Hilbert matrix dimension: {:8d}".format(n)) 57 | print("Working precision: {:8.2e}".format(eps)) 58 | print("Rank to working precision: {:8d}".format(rank)) 59 | 60 | # convenience function to summarize each sub-test 61 | def summarize(t, A, B): 62 | print("{:8.2e} (s) / {:>5}".format(t, str(np.allclose(A, B, eps)))) 63 | 64 | # convenience function to perform tests for a given type 65 | def test(desc, dz, A): 66 | desc = desc.capitalize() 67 | L = aslinearoperator(A) 68 | 69 | # test ID routines 70 | print("-----------------------------------------") 71 | print("{} ID routines".format(desc)) 72 | print("-----------------------------------------") 73 | 74 | # fixed precision 75 | print("Calling id{}p_id ...".format(dz), end=" ") 76 | t0 = time.perf_counter() 77 | k, idx, proj = pymatrixid.interp_decomp(A, eps, rand=False) 78 | t = time.perf_counter() - t0 79 | B = pymatrixid.reconstruct_matrix_from_id(A[:,idx[:k]], idx, proj) 80 | summarize(t, A, B) 81 | 82 | print("Calling id{}p_aid ...".format(dz), end=" ") 83 | t0 = time.perf_counter() 84 | k, idx, proj = pymatrixid.interp_decomp(A, eps) 85 | t = time.perf_counter() - t0 86 | B = pymatrixid.reconstruct_matrix_from_id(A[:,idx[:k]], idx, proj) 87 | summarize(t, A, B) 88 | 89 | print("Calling id{}p_rid ...".format(dz), end=" ") 90 | t0 = time.perf_counter() 91 | k, idx, proj = pymatrixid.interp_decomp(L, eps) 92 | t = time.perf_counter() - t0 93 | B = pymatrixid.reconstruct_matrix_from_id(A[:,idx[:k]], idx, proj) 94 | summarize(t, A, B) 95 | 96 | # fixed rank 97 | k = rank 98 | 99 | print("Calling id{}r_id ...".format(dz), end=" ") 100 | t0 = time.perf_counter() 101 | idx, proj = pymatrixid.interp_decomp(A, k, rand=False) 102 | t = time.perf_counter() - t0 103 | B = pymatrixid.reconstruct_matrix_from_id(A[:,idx[:k]], idx, proj) 104 | summarize(t, A, B) 105 | 106 | print("Calling id{}r_aid ...".format(dz), end=" ") 107 | t0 = time.perf_counter() 108 | idx, proj = pymatrixid.interp_decomp(A, k) 109 | t = time.perf_counter() - t0 110 | B = pymatrixid.reconstruct_matrix_from_id(A[:,idx[:k]], idx, proj) 111 | summarize(t, A, B) 112 | 113 | print("Calling id{}r_rid ...".format(dz), end=" ") 114 | t0 = time.perf_counter() 115 | idx, proj = pymatrixid.interp_decomp(L, k) 116 | t = time.perf_counter() - t0 117 | B = pymatrixid.reconstruct_matrix_from_id(A[:,idx[:k]], idx, proj) 118 | summarize(t, A, B) 119 | 120 | # test SVD routines 121 | print("-----------------------------------------") 122 | print("{} SVD routines".format(desc)) 123 | print("-----------------------------------------") 124 | 125 | # fixed precision 126 | print("Calling id{}p_svd ...".format(dz), end=" ") 127 | t0 = time.perf_counter() 128 | U, S, V = pymatrixid.svd(A, eps, rand=False) 129 | t = time.perf_counter() - t0 130 | B = U @ np.diag(S) @ V.conj().T 131 | summarize(t, A, B) 132 | 133 | print("Calling id{}p_asvd...".format(dz), end=" ") 134 | t0 = time.perf_counter() 135 | U, S, V = pymatrixid.svd(A, eps) 136 | t = time.perf_counter() - t0 137 | B = U @ np.diag(S) @ V.conj().T 138 | summarize(t, A, B) 139 | 140 | print("Calling id{}p_rsvd...".format(dz), end=" ") 141 | t0 = time.perf_counter() 142 | U, S, V = pymatrixid.svd(L, eps) 143 | t = time.perf_counter() - t0 144 | B = U @ np.diag(S) @ V.conj().T 145 | summarize(t, A, B) 146 | 147 | # fixed rank 148 | k = rank 149 | 150 | print("Calling id{}r_svd ...".format(dz), end=" ") 151 | t0 = time.perf_counter() 152 | U, S, V = pymatrixid.svd(A, k, rand=False) 153 | t = time.perf_counter() - t0 154 | B = U @ np.diag(S) @ V.conj().T 155 | summarize(t, A, B) 156 | 157 | print("Calling id{}r_asvd...".format(dz), end=" ") 158 | t0 = time.perf_counter() 159 | U, S, V = pymatrixid.svd(A, k) 160 | t = time.perf_counter() - t0 161 | B = U @ np.diag(S) @ V.conj().T 162 | summarize(t, A, B) 163 | 164 | print("Calling id{}r_rsvd...".format(dz), end=" ") 165 | t0 = time.perf_counter() 166 | U, S, V = pymatrixid.svd(L, k) 167 | t = time.perf_counter() - t0 168 | B = U @ np.diag(S) @ V.conj().T 169 | summarize(t, A, B) 170 | 171 | # test real routines 172 | test("real", "d", A) 173 | 174 | # complexify Hilbert matrix 175 | A = A*(1 + 1j) 176 | 177 | # test complex routines 178 | test("complex", "z", A) 179 | -------------------------------------------------------------------------------- /external/id_dist/README.txt: -------------------------------------------------------------------------------- 1 | Please see the documentation in subdirectory doc of this id_dist directory. 2 | 3 | At the minimum, please read Subsection 2.1 and Section 3 in the documentation, 4 | and beware that the _N.B._'s in the source code comments highlight important 5 | information about the routines -- _N.B._ stands for _nota_bene_ (Latin for 6 | "note well"). 7 | -------------------------------------------------------------------------------- /external/id_dist/development/RUNME.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | make_src.sh 4 | make_test.sh 5 | -------------------------------------------------------------------------------- /external/id_dist/development/copy_final.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ID_DIR=~/matapprox/id 4 | 5 | cp $ID_DIR/prini.f . 6 | cp $ID_DIR/dfft.f . 7 | cp $ID_DIR/idd_r_test/idd_r_test.f . 8 | cp $ID_DIR/idz_r_test/idz_r_test.f . 9 | cp $ID_DIR/idd_a_test/idd_a_test.f . 10 | cp $ID_DIR/idz_a_test/idz_a_test.f . 11 | cp $ID_DIR/idd_frm/idd_frm.f . 12 | cp $ID_DIR/idd_house/idd_house.f . 13 | cp $ID_DIR/idd_id/idd_id.f . 14 | cp $ID_DIR/idd_id2svd/idd_id2svd.f . 15 | cp $ID_DIR/iddp_aid/iddp_aid.f . 16 | cp $ID_DIR/iddp_asvd/iddp_asvd.f . 17 | cp $ID_DIR/iddp_rid/iddp_rid.f . 18 | cp $ID_DIR/iddp_rsvd/iddp_rsvd.f . 19 | cp $ID_DIR/idd_qrpiv/idd_qrpiv.f . 20 | cp $ID_DIR/iddr_aid/iddr_aid.f . 21 | cp $ID_DIR/iddr_asvd/iddr_asvd.f . 22 | cp $ID_DIR/iddr_rid/iddr_rid.f . 23 | cp $ID_DIR/iddr_rsvd/iddr_rsvd.f . 24 | cp $ID_DIR/idd_sfft/idd_sfft.f . 25 | cp $ID_DIR/idd_snorm/idd_snorm.f . 26 | cp $ID_DIR/idd_svd/idd_svd.f . 27 | cp $ID_DIR/id_rand/id_rand.f . 28 | cp $ID_DIR/id_rtrans/id_rtrans.f . 29 | cp $ID_DIR/idz_frm/idz_frm.f . 30 | cp $ID_DIR/idz_house/idz_house.f . 31 | cp $ID_DIR/idz_id/idz_id.f . 32 | cp $ID_DIR/idz_id2svd/idz_id2svd.f . 33 | cp $ID_DIR/idzp_aid/idzp_aid.f . 34 | cp $ID_DIR/idzp_asvd/idzp_asvd.f . 35 | cp $ID_DIR/idzp_rid/idzp_rid.f . 36 | cp $ID_DIR/idzp_rsvd/idzp_rsvd.f . 37 | cp $ID_DIR/idz_qrpiv/idz_qrpiv.f . 38 | cp $ID_DIR/idzr_aid/idzr_aid.f . 39 | cp $ID_DIR/idzr_asvd/idzr_asvd.f . 40 | cp $ID_DIR/idzr_rid/idzr_rid.f . 41 | cp $ID_DIR/idzr_rsvd/idzr_rsvd.f . 42 | cp $ID_DIR/idz_sfft/idz_sfft.f . 43 | cp $ID_DIR/idz_snorm/idz_snorm.f . 44 | cp $ID_DIR/idz_svd/idz_svd.f . 45 | -------------------------------------------------------------------------------- /external/id_dist/development/make_src.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | SRC_DIR=../src 4 | ARGS="-A 1000000000 this.file.contains" 5 | 6 | rm -f $SRC_DIR/*.f 7 | 8 | cp dfft.f $SRC_DIR 9 | cp prini.f $SRC_DIR 10 | 11 | grep $ARGS idd_frm.f > $SRC_DIR/idd_frm.f 12 | grep $ARGS idd_house.f > $SRC_DIR/idd_house.f 13 | grep $ARGS idd_id2svd.f > $SRC_DIR/idd_id2svd.f 14 | grep $ARGS idd_id.f > $SRC_DIR/idd_id.f 15 | grep $ARGS iddp_aid.f > $SRC_DIR/iddp_aid.f 16 | grep $ARGS iddp_asvd.f > $SRC_DIR/iddp_asvd.f 17 | grep $ARGS iddp_rid.f > $SRC_DIR/iddp_rid.f 18 | grep $ARGS iddp_rsvd.f > $SRC_DIR/iddp_rsvd.f 19 | grep $ARGS idd_qrpiv.f > $SRC_DIR/idd_qrpiv.f 20 | grep $ARGS iddr_aid.f > $SRC_DIR/iddr_aid.f 21 | grep $ARGS iddr_asvd.f > $SRC_DIR/iddr_asvd.f 22 | grep $ARGS iddr_rid.f > $SRC_DIR/iddr_rid.f 23 | grep $ARGS iddr_rsvd.f > $SRC_DIR/iddr_rsvd.f 24 | grep $ARGS idd_sfft.f > $SRC_DIR/idd_sfft.f 25 | grep $ARGS idd_snorm.f > $SRC_DIR/idd_snorm.f 26 | grep $ARGS idd_svd.f > $SRC_DIR/idd_svd.f 27 | grep $ARGS id_rand.f > $SRC_DIR/id_rand.f 28 | grep $ARGS id_rtrans.f > $SRC_DIR/id_rtrans.f 29 | grep $ARGS idz_frm.f > $SRC_DIR/idz_frm.f 30 | grep $ARGS idz_house.f > $SRC_DIR/idz_house.f 31 | grep $ARGS idz_id2svd.f > $SRC_DIR/idz_id2svd.f 32 | grep $ARGS idz_id.f > $SRC_DIR/idz_id.f 33 | grep $ARGS idzp_aid.f > $SRC_DIR/idzp_aid.f 34 | grep $ARGS idzp_asvd.f > $SRC_DIR/idzp_asvd.f 35 | grep $ARGS idzp_rid.f > $SRC_DIR/idzp_rid.f 36 | grep $ARGS idzp_rsvd.f > $SRC_DIR/idzp_rsvd.f 37 | grep $ARGS idz_qrpiv.f > $SRC_DIR/idz_qrpiv.f 38 | grep $ARGS idzr_aid.f > $SRC_DIR/idzr_aid.f 39 | grep $ARGS idzr_asvd.f > $SRC_DIR/idzr_asvd.f 40 | grep $ARGS idzr_rid.f > $SRC_DIR/idzr_rid.f 41 | grep $ARGS idzr_rsvd.f > $SRC_DIR/idzr_rsvd.f 42 | grep $ARGS idz_sfft.f > $SRC_DIR/idz_sfft.f 43 | grep $ARGS idz_snorm.f > $SRC_DIR/idz_snorm.f 44 | grep $ARGS idz_svd.f > $SRC_DIR/idz_svd.f 45 | -------------------------------------------------------------------------------- /external/id_dist/development/make_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | TEST_DIR=../test 4 | ARGS="-B 1000000 this.file.contains" 5 | 6 | rm -f $TEST_DIR/*.f 7 | 8 | cp idd_r_test.f $TEST_DIR 9 | cp idz_r_test.f $TEST_DIR 10 | cp idd_a_test.f $TEST_DIR 11 | cp idz_a_test.f $TEST_DIR 12 | 13 | grep $ARGS idd_frm.f > $TEST_DIR/idd_frm_test.f 14 | grep $ARGS idd_house.f > $TEST_DIR/idd_house_test.f 15 | grep $ARGS idd_id2svd.f > $TEST_DIR/idd_id2svd_test.f 16 | grep $ARGS idd_id.f > $TEST_DIR/idd_id_test.f 17 | grep $ARGS iddp_aid.f > $TEST_DIR/iddp_aid_test.f 18 | grep $ARGS iddp_asvd.f > $TEST_DIR/iddp_asvd_test.f 19 | grep $ARGS iddp_rid.f > $TEST_DIR/iddp_rid_test.f 20 | grep $ARGS iddp_rsvd.f > $TEST_DIR/iddp_rsvd_test.f 21 | grep $ARGS idd_qrpiv.f > $TEST_DIR/idd_qrpiv_test.f 22 | grep $ARGS iddr_aid.f > $TEST_DIR/iddr_aid_test.f 23 | grep $ARGS iddr_asvd.f > $TEST_DIR/iddr_asvd_test.f 24 | grep $ARGS iddr_rid.f > $TEST_DIR/iddr_rid_test.f 25 | grep $ARGS iddr_rsvd.f > $TEST_DIR/iddr_rsvd_test.f 26 | grep $ARGS idd_sfft.f > $TEST_DIR/idd_sfft_test.f 27 | grep $ARGS idd_snorm.f > $TEST_DIR/idd_snorm_test.f 28 | grep $ARGS idd_svd.f > $TEST_DIR/idd_svd_test.f 29 | grep $ARGS id_rand.f > $TEST_DIR/id_rand_test.f 30 | grep $ARGS id_rtrans.f > $TEST_DIR/id_rtrans_test.f 31 | grep $ARGS idz_frm.f > $TEST_DIR/idz_frm_test.f 32 | grep $ARGS idz_house.f > $TEST_DIR/idz_house_test.f 33 | grep $ARGS idz_id2svd.f > $TEST_DIR/idz_id2svd_test.f 34 | grep $ARGS idz_id.f > $TEST_DIR/idz_id_test.f 35 | grep $ARGS idzp_aid.f > $TEST_DIR/idzp_aid_test.f 36 | grep $ARGS idzp_asvd.f > $TEST_DIR/idzp_asvd_test.f 37 | grep $ARGS idzp_rid.f > $TEST_DIR/idzp_rid_test.f 38 | grep $ARGS idzp_rsvd.f > $TEST_DIR/idzp_rsvd_test.f 39 | grep $ARGS idz_qrpiv.f > $TEST_DIR/idz_qrpiv_test.f 40 | grep $ARGS idzr_aid.f > $TEST_DIR/idzr_aid_test.f 41 | grep $ARGS idzr_asvd.f > $TEST_DIR/idzr_asvd_test.f 42 | grep $ARGS idzr_rid.f > $TEST_DIR/idzr_rid_test.f 43 | grep $ARGS idzr_rsvd.f > $TEST_DIR/idzr_rsvd_test.f 44 | grep $ARGS idz_sfft.f > $TEST_DIR/idz_sfft_test.f 45 | grep $ARGS idz_snorm.f > $TEST_DIR/idz_snorm_test.f 46 | grep $ARGS idz_svd.f > $TEST_DIR/idz_svd_test.f 47 | -------------------------------------------------------------------------------- /external/id_dist/development/prini.f: -------------------------------------------------------------------------------- 1 | C 2 | C 3 | C 4 | C 5 | SUBROUTINE PRINI(IP1,IQ1) 6 | save 7 | CHARACTER *1 MES(1), AA(1) 8 | REAL *4 A(1) 9 | REAL *8 A2(1) 10 | REAL *8 A4(1) 11 | INTEGER *4 IA(1) 12 | INTEGER *2 IA2(1) 13 | IP=IP1 14 | IQ=IQ1 15 | 16 | RETURN 17 | 18 | C 19 | C 20 | C 21 | C 22 | C 23 | ENTRY PRIN(MES,A,N) 24 | CALL MESSPR(MES,IP,IQ) 25 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1200)(A(J),J=1,N) 26 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1200)(A(J),J=1,N) 27 | 1200 FORMAT(6(2X,E11.5)) 28 | RETURN 29 | C 30 | C 31 | C 32 | C 33 | ENTRY PRIN2(MES,A2,N) 34 | CALL MESSPR(MES,IP,IQ) 35 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1400)(A2(J),J=1,N) 36 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1400)(A2(J),J=1,N) 37 | 1400 FORMAT(6(2X,E11.5)) 38 | RETURN 39 | C 40 | C 41 | C 42 | C 43 | ENTRY PRIN2_long(MES,A2,N) 44 | CALL MESSPR(MES,IP,IQ) 45 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1450)(A2(J),J=1,N) 46 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1450)(A2(J),J=1,N) 47 | 1450 FORMAT(2(2X,E22.16)) 48 | RETURN 49 | C 50 | C 51 | C 52 | C 53 | ENTRY PRINQ(MES,A4,N) 54 | CALL MESSPR(MES,IP,IQ) 55 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1500)(A4(J),J=1,N) 56 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1500)(A4(J),J=1,N) 57 | 1500 FORMAT(6(2X,e11.5)) 58 | RETURN 59 | C 60 | C 61 | C 62 | C 63 | ENTRY PRINF(MES,IA,N) 64 | CALL MESSPR(MES,IP,IQ) 65 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1600)(IA(J),J=1,N) 66 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1600)(IA(J),J=1,N) 67 | 1600 FORMAT(10(1X,I7)) 68 | RETURN 69 | C 70 | C 71 | C 72 | C 73 | ENTRY PRINF2(MES,IA2,N) 74 | CALL MESSPR(MES,IP,IQ) 75 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1600)(IA2(J),J=1,N) 76 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1600)(IA2(J),J=1,N) 77 | RETURN 78 | C 79 | C 80 | C 81 | C 82 | ENTRY PRINA(MES,AA,N) 83 | CALL MESSPR(MES,IP,IQ) 84 | 2000 FORMAT(1X,80A1) 85 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,2000)(AA(J),J=1,N) 86 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,2000)(AA(J),J=1,N) 87 | RETURN 88 | END 89 | c 90 | c 91 | c 92 | c 93 | c 94 | SUBROUTINE MESSPR(MES,IP,IQ) 95 | save 96 | CHARACTER *1 MES(1),AST 97 | DATA AST/'*'/ 98 | C 99 | C DETERMINE THE LENGTH OF THE MESSAGE 100 | C 101 | I1=0 102 | DO 1400 I=1,10000 103 | IF(MES(I).EQ.AST) GOTO 1600 104 | I1=I 105 | 1400 CONTINUE 106 | 1600 CONTINUE 107 | IF ( (I1.NE.0) .AND. (IP.NE.0) ) 108 | 1 WRITE(IP,1800) (MES(I),I=1,I1) 109 | IF ( (I1.NE.0) .AND. (IQ.NE.0) ) 110 | 1 WRITE(IQ,1800) (MES(I),I=1,I1) 111 | 1800 FORMAT(1X,80A1) 112 | RETURN 113 | END 114 | C 115 | C 116 | C 117 | C 118 | C 119 | SUBROUTINE ZTIME(I) 120 | save 121 | J=1 122 | J=7-I+J 123 | CCCC I=MRUN(J) 124 | RETURN 125 | END 126 | c 127 | c 128 | c 129 | c 130 | c 131 | subroutine msgmerge(a,b,c) 132 | save 133 | character *1 a(1),b(1),c(1),ast 134 | data ast/'*'/ 135 | c 136 | do 1200 i=1,1000 137 | c 138 | if(a(i) .eq. ast) goto 1400 139 | c(i)=a(i) 140 | iadd=i 141 | 1200 continue 142 | c 143 | 1400 continue 144 | c 145 | do 1800 i=1,1000 146 | c 147 | c(iadd+i)=b(i) 148 | if(b(i) .eq. ast) return 149 | 1800 continue 150 | return 151 | end 152 | c 153 | c 154 | c 155 | c 156 | c 157 | 158 | subroutine fileflush(iw) 159 | implicit real *8 (a-h,o-z) 160 | c 161 | save 162 | close(iw) 163 | open(iw,status='old') 164 | do 1400 i=1,1000000 165 | c 166 | read(iw,1200,end=1600) 167 | 1200 format(1a1) 168 | 1400 continue 169 | 1600 continue 170 | c 171 | return 172 | end 173 | 174 | 175 | c 176 | c 177 | c 178 | c 179 | c 180 | subroutine mach_zero(zero_mach) 181 | implicit real *8 (a-h,o-z) 182 | save 183 | c 184 | zero_mach=100 185 | c 186 | d1=1.1 187 | d3=1.1 188 | d=1.11 189 | do 1200 i=1,1000 190 | c 191 | 192 | d=d/2 193 | d2=d1+d 194 | call mach_zero0(d2,d3,d4) 195 | c 196 | if(d4 .eq. 0) goto 1400 197 | c 198 | 1200 continue 199 | 1400 continue 200 | c 201 | zero_mach=d 202 | return 203 | end 204 | 205 | c 206 | c 207 | c 208 | c 209 | c 210 | subroutine mach_zero0(a,b,c) 211 | implicit real *8 (a-h,o-z) 212 | save 213 | c 214 | c=b-a 215 | 216 | return 217 | end 218 | -------------------------------------------------------------------------------- /external/id_dist/doc/doc.bib: -------------------------------------------------------------------------------- 1 | @book{golub-van_loan, 2 | author = {Gene Golub and Charles {Van L}oan}, 3 | title = {Matrix Computations}, 4 | edition = {Third}, 5 | publisher = {Johns Hopkins University Press}, 6 | year = {1996}, 7 | address = {Baltimore, Maryland} 8 | } 9 | 10 | @article{halko-martinsson-tropp, 11 | author = {Nathan Halko and {P.-G.} Martinsson and Joel A. Tropp}, 12 | title = {Finding structure with randomness: probabilistic algorithms 13 | for constructing approximate matrix decompositions}, 14 | journal = {SIAM Review}, 15 | volume = {53}, 16 | number = {2}, 17 | pages = {217--288}, 18 | year = {2011} 19 | } 20 | -------------------------------------------------------------------------------- /external/id_dist/doc/doc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/klho/PyMatrixID/3bdc86a36efd0628c031ae7fb31acaa810e801c3/external/id_dist/doc/doc.pdf -------------------------------------------------------------------------------- /external/id_dist/size.txt: -------------------------------------------------------------------------------- 1 | 100 2 | 100 3 | 4 | -------------------------------------------------------------------------------- /external/id_dist/src/iddp_asvd.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine iddp_asvd computes the SVD, to a specified precision, 5 | c of an arbitrary matrix. This routine is randomized. 6 | c 7 | c 8 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 9 | c 10 | c 11 | c 12 | c 13 | subroutine iddp_asvd(lw,eps,m,n,a,winit,krank,iu,iv,is,w,ier) 14 | c 15 | c constructs a rank-krank SVD U Sigma V^T approximating a 16 | c to precision eps, where U is an m x krank matrix whose 17 | c columns are orthonormal, V is an n x krank matrix whose 18 | c columns are orthonormal, and Sigma is a diagonal krank x krank 19 | c matrix whose entries are all nonnegative. 20 | c The entries of U are stored in w, starting at w(iu); 21 | c the entries of V are stored in w, starting at w(iv). 22 | c The diagonal entries of Sigma are stored in w, 23 | c starting at w(is). This routine uses a randomized algorithm. 24 | c 25 | c input: 26 | c lw -- maximum usable length (in real*8 elements) 27 | c of the array w 28 | c eps -- precision of the desired approximation 29 | c m -- number of rows in a 30 | c n -- number of columns in a 31 | c a -- matrix to be approximated; the present routine does not 32 | c alter a 33 | c winit -- initialization array that has been constructed 34 | c by routine idd_frmi 35 | c 36 | c output: 37 | c krank -- rank of the SVD constructed 38 | c iu -- index in w of the first entry of the matrix 39 | c of orthonormal left singular vectors of a 40 | c iv -- index in w of the first entry of the matrix 41 | c of orthonormal right singular vectors of a 42 | c is -- index in w of the first entry of the array 43 | c of singular values of a 44 | c w -- array containing the singular values and singular vectors 45 | c of a; w doubles as a work array, and so must be at least 46 | c max( (krank+1)*(3*m+5*n+1)+25*krank**2, (2*n+1)*(n2+1) ) 47 | c real*8 elements long, where n2 is the greatest integer 48 | c less than or equal to m, such that n2 is 49 | c a positive integer power of two; krank is the rank output 50 | c by this routine 51 | c ier -- 0 when the routine terminates successfully; 52 | c -1000 when lw is too small; 53 | c other nonzero values when idd_id2svd bombs 54 | c 55 | c _N.B._: w must be at least 56 | c max( (krank+1)*(3*m+5*n+1)+25*krank^2, (2*n+1)*(n2+1) ) 57 | c real*8 elements long, where n2 is the greatest integer 58 | c less than or equal to m, such that n2 is 59 | c a positive integer power of two; 60 | c krank is the rank output by this routine. 61 | c Also, the algorithm used by this routine is randomized. 62 | c 63 | implicit none 64 | integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, 65 | 1 iwork,lwork,k,ier,lw2,iu,iv,is,iui,ivi,isi,lu,lv,ls 66 | real*8 eps,a(m,n),winit(17*m+70),w(*) 67 | c 68 | c 69 | c Allocate memory in w. 70 | c 71 | lw2 = 0 72 | c 73 | ilist = lw2+1 74 | llist = n 75 | lw2 = lw2+llist 76 | c 77 | iproj = lw2+1 78 | c 79 | c 80 | c ID a. 81 | c 82 | call iddp_aid(eps,m,n,a,winit,krank,w(ilist),w(iproj)) 83 | c 84 | c 85 | if(krank .gt. 0) then 86 | c 87 | c 88 | c Allocate more memory in w. 89 | c 90 | lproj = krank*(n-krank) 91 | lw2 = lw2+lproj 92 | c 93 | icol = lw2+1 94 | lcol = m*krank 95 | lw2 = lw2+lcol 96 | c 97 | iui = lw2+1 98 | lu = m*krank 99 | lw2 = lw2+lu 100 | c 101 | ivi = lw2+1 102 | lv = n*krank 103 | lw2 = lw2+lv 104 | c 105 | isi = lw2+1 106 | ls = krank 107 | lw2 = lw2+ls 108 | c 109 | iwork = lw2+1 110 | lwork = (krank+1)*(m+3*n)+26*krank**2 111 | lw2 = lw2+lwork 112 | c 113 | c 114 | if(lw .lt. lw2) then 115 | ier = -1000 116 | return 117 | endif 118 | c 119 | c 120 | call iddp_asvd0(m,n,a,krank,w(ilist),w(iproj), 121 | 1 w(iui),w(ivi),w(isi),ier,w(icol),w(iwork)) 122 | if(ier .ne. 0) return 123 | c 124 | c 125 | iu = 1 126 | iv = iu+lu 127 | is = iv+lv 128 | c 129 | c 130 | c Copy the singular values and singular vectors 131 | c into their proper locations. 132 | c 133 | do k = 1,lu 134 | w(iu+k-1) = w(iui+k-1) 135 | enddo ! k 136 | c 137 | do k = 1,lv 138 | w(iv+k-1) = w(ivi+k-1) 139 | enddo ! k 140 | c 141 | do k = 1,ls 142 | w(is+k-1) = w(isi+k-1) 143 | enddo ! k 144 | c 145 | c 146 | endif ! krank .gt. 0 147 | c 148 | c 149 | return 150 | end 151 | c 152 | c 153 | c 154 | c 155 | subroutine iddp_asvd0(m,n,a,krank,list,proj,u,v,s,ier, 156 | 1 col,work) 157 | c 158 | c routine iddp_asvd serves as a memory wrapper 159 | c for the present routine (please see routine iddp_asvd 160 | c for further documentation). 161 | c 162 | implicit none 163 | integer m,n,krank,list(n),ier 164 | real*8 a(m,n),u(m,krank),v(n,krank), 165 | 1 s(krank),proj(krank,n-krank),col(m,krank), 166 | 2 work((krank+1)*(m+3*n)+26*krank**2) 167 | c 168 | c 169 | c Collect together the columns of a indexed by list into col. 170 | c 171 | call idd_copycols(m,n,a,krank,list,col) 172 | c 173 | c 174 | c Convert the ID to an SVD. 175 | c 176 | call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) 177 | c 178 | c 179 | return 180 | end 181 | -------------------------------------------------------------------------------- /external/id_dist/src/iddr_aid.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine iddr_aid computes the ID, to a specified rank, 5 | c of an arbitrary matrix. This routine is randomized. 6 | c 7 | c routine iddr_aidi initializes routine iddr_aid. 8 | c 9 | c 10 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 11 | c 12 | c 13 | c 14 | c 15 | subroutine iddr_aid(m,n,a,krank,w,list,proj) 16 | c 17 | c computes the ID of the matrix a, i.e., lists in list 18 | c the indices of krank columns of a such that 19 | c 20 | c a(j,list(k)) = a(j,list(k)) 21 | c 22 | c for all j = 1, ..., m; k = 1, ..., krank, and 23 | c 24 | c min(m,n,krank) 25 | c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) 26 | c l=1 27 | c 28 | c + epsilon(j,k-krank) 29 | c 30 | c for all j = 1, ..., m; k = krank+1, ..., n, 31 | c 32 | c for some matrix epsilon, dimensioned epsilon(m,n-krank), 33 | c whose norm is (hopefully) minimized by the pivoting procedure. 34 | c 35 | c input: 36 | c m -- number of rows in a 37 | c n -- number of columns in a 38 | c a -- matrix to be ID'd; the present routine does not alter a 39 | c krank -- rank of the ID to be constructed 40 | c w -- initialization array that routine iddr_aidi 41 | c has constructed 42 | c 43 | c output: 44 | c list -- indices of the columns in the ID 45 | c proj -- matrix of coefficients needed to interpolate 46 | c from the selected columns to the other columns 47 | c in the original matrix being ID'd 48 | c 49 | c _N.B._: The algorithm used by this routine is randomized. 50 | c 51 | c reference: 52 | c Halko, Martinsson, Tropp, "Finding structure with randomness: 53 | c probabilistic algorithms for constructing approximate 54 | c matrix decompositions," SIAM Review, 53 (2): 217-288, 55 | c 2011. 56 | c 57 | implicit none 58 | integer m,n,krank,list(n),lw,ir,lr,lw2,iw 59 | real*8 a(m,n),proj(krank*(n-krank)),w((2*krank+17)*n+27*m+100) 60 | c 61 | c 62 | c Allocate memory in w. 63 | c 64 | lw = 0 65 | c 66 | iw = lw+1 67 | lw2 = 27*m+100+n 68 | lw = lw+lw2 69 | c 70 | ir = lw+1 71 | lr = (krank+8)*2*n 72 | lw = lw+lr 73 | c 74 | c 75 | call iddr_aid0(m,n,a,krank,w(iw),list,proj,w(ir)) 76 | c 77 | c 78 | return 79 | end 80 | c 81 | c 82 | c 83 | c 84 | subroutine iddr_aid0(m,n,a,krank,w,list,proj,r) 85 | c 86 | c routine iddr_aid serves as a memory wrapper 87 | c for the present routine 88 | c (see iddr_aid for further documentation). 89 | c 90 | implicit none 91 | integer k,l,m,n2,n,krank,list(n),mn,lproj 92 | real*8 a(m,n),r(krank+8,2*n),proj(krank,n-krank), 93 | 1 w(27*m+100+n) 94 | c 95 | c Please note that the second dimension of r is 2*n 96 | c (instead of n) so that if krank+8 >= m/2, then 97 | c we can copy the whole of a into r. 98 | c 99 | c 100 | c Retrieve the number of random test vectors 101 | c and the greatest integer less than m that is 102 | c a positive integer power of two. 103 | c 104 | l = w(1) 105 | n2 = w(2) 106 | c 107 | c 108 | if(l .lt. n2 .and. l .le. m) then 109 | c 110 | c Apply the random matrix. 111 | c 112 | do k = 1,n 113 | call idd_sfrm(l,m,n2,w(11),a(1,k),r(1,k)) 114 | enddo ! k 115 | c 116 | c ID r. 117 | c 118 | call iddr_id(l,n,r,krank,list,w(26*m+101)) 119 | c 120 | c Retrieve proj from r. 121 | c 122 | lproj = krank*(n-krank) 123 | call iddr_copydarr(lproj,r,proj) 124 | c 125 | endif 126 | c 127 | c 128 | if(l .ge. n2 .or. l .gt. m) then 129 | c 130 | c ID a directly. 131 | c 132 | mn = m*n 133 | call iddr_copydarr(mn,a,r) 134 | call iddr_id(m,n,r,krank,list,w(26*m+101)) 135 | c 136 | c Retrieve proj from r. 137 | c 138 | lproj = krank*(n-krank) 139 | call iddr_copydarr(lproj,r,proj) 140 | c 141 | endif 142 | c 143 | c 144 | return 145 | end 146 | c 147 | c 148 | c 149 | c 150 | subroutine iddr_copydarr(n,a,b) 151 | c 152 | c copies a into b. 153 | c 154 | c input: 155 | c n -- length of a and b 156 | c a -- array to copy into b 157 | c 158 | c output: 159 | c b -- copy of a 160 | c 161 | implicit none 162 | integer n,k 163 | real*8 a(n),b(n) 164 | c 165 | c 166 | do k = 1,n 167 | b(k) = a(k) 168 | enddo ! k 169 | c 170 | c 171 | return 172 | end 173 | c 174 | c 175 | c 176 | c 177 | subroutine iddr_aidi(m,n,krank,w) 178 | c 179 | c initializes the array w for using routine iddr_aid. 180 | c 181 | c input: 182 | c m -- number of rows in the matrix to be ID'd 183 | c n -- number of columns in the matrix to be ID'd 184 | c krank -- rank of the ID to be constructed 185 | c 186 | c output: 187 | c w -- initialization array for using routine iddr_aid 188 | c 189 | implicit none 190 | integer m,n,krank,l,n2 191 | real*8 w((2*krank+17)*n+27*m+100) 192 | c 193 | c 194 | c Set the number of random test vectors to 8 more than the rank. 195 | c 196 | l = krank+8 197 | w(1) = l 198 | c 199 | c 200 | c Initialize the rest of the array w. 201 | c 202 | n2 = 0 203 | if(l .le. m) call idd_sfrmi(l,m,n2,w(11)) 204 | w(2) = n2 205 | c 206 | c 207 | return 208 | end 209 | -------------------------------------------------------------------------------- /external/id_dist/src/iddr_asvd.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine iddr_aid computes the SVD, to a specified rank, 5 | c of an arbitrary matrix. This routine is randomized. 6 | c 7 | c 8 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 9 | c 10 | c 11 | c 12 | c 13 | subroutine iddr_asvd(m,n,a,krank,w,u,v,s,ier) 14 | c 15 | c constructs a rank-krank SVD u diag(s) v^T approximating a, 16 | c where u is an m x krank matrix whose columns are orthonormal, 17 | c v is an n x krank matrix whose columns are orthonormal, 18 | c and diag(s) is a diagonal krank x krank matrix whose entries 19 | c are all nonnegative. This routine uses a randomized algorithm. 20 | c 21 | c input: 22 | c m -- number of rows in a 23 | c n -- number of columns in a 24 | c a -- matrix to be decomposed; the present routine does not 25 | c alter a 26 | c krank -- rank of the SVD being constructed 27 | c w -- initialization array that routine iddr_aidi 28 | c has constructed (for use in the present routine, w must 29 | c be at least (2*krank+28)*m+(6*krank+21)*n+25*krank**2+100 30 | c real*8 elements long) 31 | c 32 | c output: 33 | c u -- matrix of orthonormal left singular vectors of a 34 | c v -- matrix of orthonormal right singular vectors of a 35 | c s -- array of singular values of a 36 | c ier -- 0 when the routine terminates successfully; 37 | c nonzero otherwise 38 | c 39 | c _N.B._: The algorithm used by this routine is randomized. 40 | c 41 | implicit none 42 | integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, 43 | 1 iwork,lwork,iwinit,lwinit,ier 44 | real*8 a(m,n),u(m,krank),v(n,krank),s(krank), 45 | 1 w((2*krank+28)*m+(6*krank+21)*n+25*krank**2+100) 46 | c 47 | c 48 | c Allocate memory in w. 49 | c 50 | lw = 0 51 | c 52 | iwinit = lw+1 53 | lwinit = (2*krank+17)*n+27*m+100 54 | lw = lw+lwinit 55 | c 56 | ilist = lw+1 57 | llist = n 58 | lw = lw+llist 59 | c 60 | iproj = lw+1 61 | lproj = krank*(n-krank) 62 | lw = lw+lproj 63 | c 64 | icol = lw+1 65 | lcol = m*krank 66 | lw = lw+lcol 67 | c 68 | iwork = lw+1 69 | lwork = (krank+1)*(m+3*n)+26*krank**2 70 | lw = lw+lwork 71 | c 72 | c 73 | call iddr_asvd0(m,n,a,krank,w(iwinit),u,v,s,ier, 74 | 1 w(ilist),w(iproj),w(icol),w(iwork)) 75 | c 76 | c 77 | return 78 | end 79 | c 80 | c 81 | c 82 | c 83 | subroutine iddr_asvd0(m,n,a,krank,winit,u,v,s,ier, 84 | 1 list,proj,col,work) 85 | c 86 | c routine iddr_asvd serves as a memory wrapper 87 | c for the present routine (please see routine iddr_asvd 88 | c for further documentation). 89 | c 90 | implicit none 91 | integer m,n,krank,list(n),ier 92 | real*8 a(m,n),u(m,krank),v(n,krank),s(krank), 93 | 1 proj(krank,n-krank),col(m*krank), 94 | 2 winit((2*krank+17)*n+27*m+100), 95 | 3 work((krank+1)*(m+3*n)+26*krank**2) 96 | c 97 | c 98 | c ID a. 99 | c 100 | call iddr_aid(m,n,a,krank,winit,list,proj) 101 | c 102 | c 103 | c Collect together the columns of a indexed by list into col. 104 | c 105 | call idd_copycols(m,n,a,krank,list,col) 106 | c 107 | c 108 | c Convert the ID to an SVD. 109 | c 110 | call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) 111 | c 112 | c 113 | return 114 | end 115 | -------------------------------------------------------------------------------- /external/id_dist/src/iddr_rid.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine iddr_rid computes the ID, to a specified rank, 5 | c of a matrix specified by a routine for applying its transpose 6 | c to arbitrary vectors. This routine is randomized. 7 | c 8 | c 9 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 10 | c 11 | c 12 | c 13 | c 14 | subroutine iddr_rid(m,n,matvect,p1,p2,p3,p4,krank,list,proj) 15 | c 16 | c computes the ID of a matrix "a" specified by 17 | c the routine matvect -- matvect must apply the transpose 18 | c of the matrix being ID'd to an arbitrary vector -- 19 | c i.e., the present routine lists in list the indices 20 | c of krank columns of a such that 21 | c 22 | c a(j,list(k)) = a(j,list(k)) 23 | c 24 | c for all j = 1, ..., m; k = 1, ..., krank, and 25 | c 26 | c min(m,n,krank) 27 | c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) 28 | c l=1 29 | c 30 | c + epsilon(j,k-krank) 31 | c 32 | c for all j = 1, ..., m; k = krank+1, ..., n, 33 | c 34 | c for some matrix epsilon, dimensioned epsilon(m,n-krank), 35 | c whose norm is (hopefully) minimized by the pivoting procedure. 36 | c 37 | c input: 38 | c m -- number of rows in the matrix to be ID'd 39 | c n -- number of columns in the matrix to be ID'd 40 | c matvect -- routine which applies the transpose 41 | c of the matrix to be ID'd to an arbitrary vector; 42 | c this routine must have a calling sequence 43 | c of the form 44 | c 45 | c matvect(m,x,n,y,p1,p2,p3,p4), 46 | c 47 | c where m is the length of x, 48 | c x is the vector to which the transpose 49 | c of the matrix is to be applied, 50 | c n is the length of y, 51 | c y is the product of the transposed matrix and x, 52 | c and p1, p2, p3, and p4 are user-specified parameters 53 | c p1 -- parameter to be passed to routine matvect 54 | c p2 -- parameter to be passed to routine matvect 55 | c p3 -- parameter to be passed to routine matvect 56 | c p4 -- parameter to be passed to routine matvect 57 | c krank -- rank of the ID to be constructed 58 | c 59 | c output: 60 | c list -- indices of the columns in the ID 61 | c proj -- matrix of coefficients needed to interpolate 62 | c from the selected columns to the other columns 63 | c in the original matrix being ID'd; 64 | c proj doubles as a work array in the present routine, so 65 | c proj must be at least m+(krank+3)*n real*8 elements 66 | c long 67 | c 68 | c _N.B._: The algorithm used by this routine is randomized. 69 | c proj must be at least m+(krank+3)*n real*8 elements 70 | c long. 71 | c 72 | c reference: 73 | c Halko, Martinsson, Tropp, "Finding structure with randomness: 74 | c probabilistic algorithms for constructing approximate 75 | c matrix decompositions," SIAM Review, 53 (2): 217-288, 76 | c 2011. 77 | c 78 | implicit none 79 | integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr 80 | real*8 p1,p2,p3,p4,proj(m+(krank+3)*n) 81 | external matvect 82 | c 83 | c 84 | c Allocate memory in w. 85 | c 86 | lw = 0 87 | c 88 | ir = lw+1 89 | lr = (krank+2)*n 90 | lw = lw+lr 91 | c 92 | ix = lw+1 93 | lx = m 94 | lw = lw+lx 95 | c 96 | iy = lw+1 97 | ly = n 98 | lw = lw+ly 99 | c 100 | c 101 | call iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank, 102 | 1 list,proj(ir),proj(ix),proj(iy)) 103 | c 104 | c 105 | return 106 | end 107 | c 108 | c 109 | c 110 | c 111 | subroutine iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank, 112 | 1 list,r,x,y) 113 | c 114 | c routine iddr_ridall serves as a memory wrapper 115 | c for the present routine 116 | c (see iddr_ridall for further documentation). 117 | c 118 | implicit none 119 | integer j,k,l,m,n,krank,list(n) 120 | real*8 x(m),y(n),p1,p2,p3,p4,r(krank+2,n) 121 | external matvect 122 | c 123 | c 124 | c Set the number of random test vectors to 2 more than the rank. 125 | c 126 | l = krank+2 127 | c 128 | c Apply the transpose of the original matrix to l random vectors. 129 | c 130 | do j = 1,l 131 | c 132 | c Generate a random vector. 133 | c 134 | call id_srand(m,x) 135 | c 136 | c Apply the transpose of the matrix to x, obtaining y. 137 | c 138 | call matvect(m,x,n,y,p1,p2,p3,p4) 139 | c 140 | c Copy y into row j of r. 141 | c 142 | do k = 1,n 143 | r(j,k) = y(k) 144 | enddo ! k 145 | c 146 | enddo ! j 147 | c 148 | c 149 | c ID r. 150 | c 151 | call iddr_id(l,n,r,krank,list,y) 152 | c 153 | c 154 | return 155 | end 156 | -------------------------------------------------------------------------------- /external/id_dist/src/iddr_rsvd.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine iddr_rsvd computes the SVD, to a specified rank, 5 | c of a matrix specified by routines for applying the matrix 6 | c and its transpose to arbitrary vectors. 7 | c This routine is randomized. 8 | c 9 | c 10 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 11 | c 12 | c 13 | c 14 | c 15 | subroutine iddr_rsvd(m,n,matvect,p1t,p2t,p3t,p4t, 16 | 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier,w) 17 | c 18 | c constructs a rank-krank SVD u diag(s) v^T approximating a, 19 | c where matvect is a routine which applies a^T 20 | c to an arbitrary vector, and matvec is a routine 21 | c which applies a to an arbitrary vector; 22 | c u is an m x krank matrix whose columns are orthonormal, 23 | c v is an n x krank matrix whose columns are orthonormal, 24 | c and diag(s) is a diagonal krank x krank matrix whose entries 25 | c are all nonnegative. This routine uses a randomized algorithm. 26 | c 27 | c input: 28 | c m -- number of rows in a 29 | c n -- number of columns in a 30 | c matvect -- routine which applies the transpose 31 | c of the matrix to be SVD'd 32 | c to an arbitrary vector; this routine must have 33 | c a calling sequence of the form 34 | c 35 | c matvect(m,x,n,y,p1t,p2t,p3t,p4t), 36 | c 37 | c where m is the length of x, 38 | c x is the vector to which the transpose 39 | c of the matrix is to be applied, 40 | c n is the length of y, 41 | c y is the product of the transposed matrix and x, 42 | c and p1t, p2t, p3t, and p4t are user-specified 43 | c parameters 44 | c p1t -- parameter to be passed to routine matvect 45 | c p2t -- parameter to be passed to routine matvect 46 | c p3t -- parameter to be passed to routine matvect 47 | c p4t -- parameter to be passed to routine matvect 48 | c matvec -- routine which applies the matrix to be SVD'd 49 | c to an arbitrary vector; this routine must have 50 | c a calling sequence of the form 51 | c 52 | c matvec(n,x,m,y,p1,p2,p3,p4), 53 | c 54 | c where n is the length of x, 55 | c x is the vector to which the matrix is to be applied, 56 | c m is the length of y, 57 | c y is the product of the matrix and x, 58 | c and p1, p2, p3, and p4 are user-specified parameters 59 | c p1 -- parameter to be passed to routine matvec 60 | c p2 -- parameter to be passed to routine matvec 61 | c p3 -- parameter to be passed to routine matvec 62 | c p4 -- parameter to be passed to routine matvec 63 | c krank -- rank of the SVD being constructed 64 | c 65 | c output: 66 | c u -- matrix of orthonormal left singular vectors of a 67 | c v -- matrix of orthonormal right singular vectors of a 68 | c s -- array of singular values of a 69 | c ier -- 0 when the routine terminates successfully; 70 | c nonzero otherwise 71 | c 72 | c work: 73 | c w -- must be at least (krank+1)*(2*m+4*n)+25*krank**2 74 | c real*8 elements long 75 | c 76 | c _N.B._: The algorithm used by this routine is randomized. 77 | c 78 | implicit none 79 | integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, 80 | 1 iwork,lwork,ier 81 | real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), 82 | 1 s(krank),w((krank+1)*(2*m+4*n)+25*krank**2) 83 | external matvect,matvec 84 | c 85 | c 86 | c Allocate memory in w. 87 | c 88 | lw = 0 89 | c 90 | ilist = lw+1 91 | llist = n 92 | lw = lw+llist 93 | c 94 | iproj = lw+1 95 | lproj = krank*(n-krank) 96 | lw = lw+lproj 97 | c 98 | icol = lw+1 99 | lcol = m*krank 100 | lw = lw+lcol 101 | c 102 | iwork = lw+1 103 | lwork = (krank+1)*(m+3*n)+26*krank**2 104 | lw = lw+lwork 105 | c 106 | c 107 | call iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t, 108 | 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, 109 | 2 w(ilist),w(iproj),w(icol),w(iwork)) 110 | c 111 | c 112 | return 113 | end 114 | c 115 | c 116 | c 117 | c 118 | subroutine iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t, 119 | 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, 120 | 2 list,proj,col,work) 121 | c 122 | c routine iddr_rsvd serves as a memory wrapper 123 | c for the present routine (please see routine iddr_rsvd 124 | c for further documentation). 125 | c 126 | implicit none 127 | integer m,n,krank,list(n),ier,k 128 | real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), 129 | 1 s(krank),proj(krank*(n-krank)),col(m*krank), 130 | 2 work((krank+1)*(m+3*n)+26*krank**2) 131 | external matvect,matvec 132 | c 133 | c 134 | c ID a. 135 | c 136 | call iddr_rid(m,n,matvect,p1t,p2t,p3t,p4t,krank,list,work) 137 | c 138 | c 139 | c Retrieve proj from work. 140 | c 141 | do k = 1,krank*(n-krank) 142 | proj(k) = work(k) 143 | enddo ! k 144 | c 145 | c 146 | c Collect together the columns of a indexed by list into col. 147 | c 148 | call idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work) 149 | c 150 | c 151 | c Convert the ID to an SVD. 152 | c 153 | call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) 154 | c 155 | c 156 | return 157 | end 158 | -------------------------------------------------------------------------------- /external/id_dist/src/idz_sfft.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine idz_sffti initializes routine idz_sfft. 5 | c 6 | c routine idz_sfft rapidly computes a subset of the entries 7 | c of the DFT of a vector, composed with permutation matrices 8 | c both on input and on output. 9 | c 10 | c routine idz_ldiv finds the greatest integer less than or equal 11 | c to a specified integer, that is divisible by another (larger) 12 | c specified integer. 13 | c 14 | c 15 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 16 | c 17 | c 18 | c 19 | c 20 | subroutine idz_ldiv(l,n,m) 21 | c 22 | c finds the greatest integer less than or equal to l 23 | c that divides n. 24 | c 25 | c input: 26 | c l -- integer at least as great as m 27 | c n -- integer divisible by m 28 | c 29 | c output: 30 | c m -- greatest integer less than or equal to l that divides n 31 | c 32 | implicit none 33 | integer n,l,m 34 | c 35 | c 36 | m = l 37 | c 38 | 1000 continue 39 | if(m*(n/m) .eq. n) goto 2000 40 | c 41 | m = m-1 42 | goto 1000 43 | c 44 | 2000 continue 45 | c 46 | c 47 | return 48 | end 49 | c 50 | c 51 | c 52 | c 53 | subroutine idz_sffti(l,ind,n,wsave) 54 | c 55 | c initializes wsave for use with routine idz_sfft. 56 | c 57 | c input: 58 | c l -- number of entries in the output of idz_sfft to compute 59 | c ind -- indices of the entries in the output of idz_sfft 60 | c to compute 61 | c n -- length of the vector to be transformed 62 | c 63 | c output: 64 | c wsave -- array needed by routine idz_sfft for processing 65 | c 66 | implicit none 67 | integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k 68 | real*8 r1,twopi,fact 69 | complex*16 wsave(2*l+15+3*n),ci,twopii 70 | c 71 | ci = (0,1) 72 | r1 = 1 73 | twopi = 2*4*atan(r1) 74 | twopii = twopi*ci 75 | c 76 | c 77 | c Determine the block lengths for the FFTs. 78 | c 79 | call idz_ldiv(l,n,nblock) 80 | m = n/nblock 81 | c 82 | c 83 | c Initialize wsave for use with routine zfftf. 84 | c 85 | call zffti(nblock,wsave) 86 | c 87 | c 88 | c Calculate the coefficients in the linear combinations 89 | c needed for the direct portion of the calculation. 90 | c 91 | fact = 1/sqrt(r1*n) 92 | c 93 | ii = 2*l+15 94 | c 95 | do j = 1,l 96 | c 97 | i = ind(j) 98 | c 99 | idivm = (i-1)/m 100 | imodm = (i-1)-m*idivm 101 | c 102 | do k = 1,m 103 | wsave(ii+m*(j-1)+k) = exp(-twopii*imodm*(k-1)/(r1*m)) 104 | 1 * exp(-twopii*(k-1)*idivm/(r1*n)) * fact 105 | enddo ! k 106 | c 107 | enddo ! j 108 | c 109 | c 110 | return 111 | end 112 | c 113 | c 114 | c 115 | c 116 | subroutine idz_sfft(l,ind,n,wsave,v) 117 | c 118 | c computes a subset of the entries of the DFT of v, 119 | c composed with permutation matrices both on input and on output, 120 | c via a two-stage procedure (routine zfftf2 is supposed 121 | c to calculate the full vector from which idz_sfft returns 122 | c a subset of the entries, when zfftf2 has the same parameter 123 | c nblock as in the present routine). 124 | c 125 | c input: 126 | c l -- number of entries in the output to compute 127 | c ind -- indices of the entries of the output to compute 128 | c n -- length of v 129 | c v -- vector to be transformed 130 | c wsave -- processing array initialized by routine idz_sffti 131 | c 132 | c output: 133 | c v -- entries indexed by ind are given their appropriate 134 | c transformed values 135 | c 136 | c _N.B._: The user has to boost the memory allocations 137 | c for wsave (and change iii accordingly) if s/he wishes 138 | c to use strange sizes of n; it's best to stick to powers 139 | c of 2. 140 | c 141 | c references: 142 | c Sorensen and Burrus, "Efficient computation of the DFT with 143 | c only a subset of input or output points," 144 | c IEEE Transactions on Signal Processing, 41 (3): 1184-1200, 145 | c 1993. 146 | c Woolfe, Liberty, Rokhlin, Tygert, "A fast randomized algorithm 147 | c for the approximation of matrices," Applied and 148 | c Computational Harmonic Analysis, 25 (3): 335-366, 2008; 149 | c Section 3.3. 150 | c 151 | implicit none 152 | integer n,m,l,k,j,ind(l),i,idivm,nblock,ii,iii 153 | real*8 r1,twopi 154 | complex*16 v(n),wsave(2*l+15+3*n),ci,sum 155 | c 156 | ci = (0,1) 157 | r1 = 1 158 | twopi = 2*4*atan(r1) 159 | c 160 | c 161 | c Determine the block lengths for the FFTs. 162 | c 163 | call idz_ldiv(l,n,nblock) 164 | c 165 | c 166 | m = n/nblock 167 | c 168 | c 169 | c FFT each block of length nblock of v. 170 | c 171 | do k = 1,m 172 | call zfftf(nblock,v(nblock*(k-1)+1),wsave) 173 | enddo ! k 174 | c 175 | c 176 | c Transpose v to obtain wsave(2*l+15+2*n+1 : 2*l+15+3*n). 177 | c 178 | iii = 2*l+15+2*n 179 | c 180 | do k = 1,m 181 | do j = 1,nblock 182 | wsave(iii+m*(j-1)+k) = v(nblock*(k-1)+j) 183 | enddo ! j 184 | enddo ! k 185 | c 186 | c 187 | c Directly calculate the desired entries of v. 188 | c 189 | ii = 2*l+15 190 | iii = 2*l+15+2*n 191 | c 192 | do j = 1,l 193 | c 194 | i = ind(j) 195 | c 196 | idivm = (i-1)/m 197 | c 198 | sum = 0 199 | c 200 | do k = 1,m 201 | sum = sum + wsave(ii+m*(j-1)+k) * wsave(iii+m*idivm+k) 202 | enddo ! k 203 | c 204 | v(i) = sum 205 | c 206 | enddo ! j 207 | c 208 | c 209 | return 210 | end 211 | -------------------------------------------------------------------------------- /external/id_dist/src/idzp_asvd.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine idzp_asvd computes the SVD, to a specified precision, 5 | c of an arbitrary matrix. This routine is randomized. 6 | c 7 | c 8 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 9 | c 10 | c 11 | c 12 | c 13 | subroutine idzp_asvd(lw,eps,m,n,a,winit,krank,iu,iv,is,w,ier) 14 | c 15 | c constructs a rank-krank SVD U Sigma V^* approximating a 16 | c to precision eps, where U is an m x krank matrix whose 17 | c columns are orthonormal, V is an n x krank matrix whose 18 | c columns are orthonormal, and Sigma is a diagonal krank x krank 19 | c matrix whose entries are all nonnegative. 20 | c The entries of U are stored in w, starting at w(iu); 21 | c the entries of V are stored in w, starting at w(iv). 22 | c The diagonal entries of Sigma are stored in w, 23 | c starting at w(is). This routine uses a randomized algorithm. 24 | c 25 | c input: 26 | c lw -- maximum usable length (in complex*16 elements) 27 | c of the array w 28 | c eps -- precision of the desired approximation 29 | c m -- number of rows in a 30 | c n -- number of columns in a 31 | c a -- matrix to be approximated; the present routine does not 32 | c alter a 33 | c winit -- initialization array that has been constructed 34 | c by routine idz_frmi 35 | c 36 | c output: 37 | c krank -- rank of the SVD constructed 38 | c iu -- index in w of the first entry of the matrix 39 | c of orthonormal left singular vectors of a 40 | c iv -- index in w of the first entry of the matrix 41 | c of orthonormal right singular vectors of a 42 | c is -- index in w of the first entry of the array 43 | c of singular values of a 44 | c w -- array containing the singular values and singular vectors 45 | c of a; w doubles as a work array, and so must be at least 46 | c max( (krank+1)*(3*m+5*n+11)+8*krank**2, (2*n+1)*(n2+1) ) 47 | c complex*16 elements long, where n2 is the greatest integer 48 | c less than or equal to m, such that n2 is 49 | c a positive integer power of two; krank is the rank output 50 | c by this routine 51 | c ier -- 0 when the routine terminates successfully; 52 | c -1000 when lw is too small; 53 | c other nonzero values when idz_id2svd bombs 54 | c 55 | c _N.B._: w must be at least 56 | c max( (krank+1)*(3*m+5*n+11)+8*krank^2, (2*n+1)*(n2+1) ) 57 | c complex*16 elements long, where n2 is 58 | c the greatest integer less than or equal to m, 59 | c such that n2 is a positive integer power of two; 60 | c krank is the rank output by this routine. 61 | c Also, the algorithm used by this routine is randomized. 62 | c 63 | implicit none 64 | integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, 65 | 1 iwork,lwork,k,ier,lw2,iu,iv,is,iui,ivi,isi,lu,lv,ls 66 | real*8 eps 67 | complex*16 a(m,n),winit(17*m+70),w(*) 68 | c 69 | c 70 | c Allocate memory in w. 71 | c 72 | lw2 = 0 73 | c 74 | ilist = lw2+1 75 | llist = n 76 | lw2 = lw2+llist 77 | c 78 | iproj = lw2+1 79 | c 80 | c 81 | c ID a. 82 | c 83 | call idzp_aid(eps,m,n,a,winit,krank,w(ilist),w(iproj)) 84 | c 85 | c 86 | if(krank .gt. 0) then 87 | c 88 | c 89 | c Allocate more memory in w. 90 | c 91 | lproj = krank*(n-krank) 92 | lw2 = lw2+lproj 93 | c 94 | icol = lw2+1 95 | lcol = m*krank 96 | lw2 = lw2+lcol 97 | c 98 | iui = lw2+1 99 | lu = m*krank 100 | lw2 = lw2+lu 101 | c 102 | ivi = lw2+1 103 | lv = n*krank 104 | lw2 = lw2+lv 105 | c 106 | isi = lw2+1 107 | ls = krank 108 | lw2 = lw2+ls 109 | c 110 | iwork = lw2+1 111 | lwork = (krank+1)*(m+3*n+10)+9*krank**2 112 | lw2 = lw2+lwork 113 | c 114 | c 115 | if(lw .lt. lw2) then 116 | ier = -1000 117 | return 118 | endif 119 | c 120 | c 121 | call idzp_asvd0(m,n,a,krank,w(ilist),w(iproj), 122 | 1 w(iui),w(ivi),w(isi),ier,w(icol),w(iwork)) 123 | if(ier .ne. 0) return 124 | c 125 | c 126 | iu = 1 127 | iv = iu+lu 128 | is = iv+lv 129 | c 130 | c 131 | c Copy the singular values and singular vectors 132 | c into their proper locations. 133 | c 134 | do k = 1,lu 135 | w(iu+k-1) = w(iui+k-1) 136 | enddo ! k 137 | c 138 | do k = 1,lv 139 | w(iv+k-1) = w(ivi+k-1) 140 | enddo ! k 141 | c 142 | call idz_realcomplex(ls,w(isi),w(is)) 143 | c 144 | c 145 | endif ! krank .gt. 0 146 | c 147 | c 148 | return 149 | end 150 | c 151 | c 152 | c 153 | c 154 | subroutine idzp_asvd0(m,n,a,krank,list,proj,u,v,s,ier, 155 | 1 col,work) 156 | c 157 | c routine idzp_asvd serves as a memory wrapper 158 | c for the present routine (please see routine idzp_asvd 159 | c for further documentation). 160 | c 161 | implicit none 162 | integer m,n,krank,list(n),ier 163 | real*8 s(krank) 164 | complex*16 a(m,n),u(m,krank),v(n,krank), 165 | 1 proj(krank,n-krank),col(m,krank), 166 | 2 work((krank+1)*(m+3*n+10)+9*krank**2) 167 | c 168 | c 169 | c Collect together the columns of a indexed by list into col. 170 | c 171 | call idz_copycols(m,n,a,krank,list,col) 172 | c 173 | c 174 | c Convert the ID to an SVD. 175 | c 176 | call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) 177 | c 178 | c 179 | return 180 | end 181 | c 182 | c 183 | c 184 | c 185 | subroutine idz_realcomplex(n,a,b) 186 | c 187 | c copies the real*8 array a into the complex*16 array b. 188 | c 189 | c input: 190 | c n -- length of a and b 191 | c a -- real*8 array to be copied into b 192 | c 193 | c output: 194 | c b -- complex*16 copy of a 195 | c 196 | integer n,k 197 | real*8 a(n) 198 | complex*16 b(n) 199 | c 200 | c 201 | do k = 1,n 202 | b(k) = a(k) 203 | enddo ! k 204 | c 205 | c 206 | return 207 | end 208 | -------------------------------------------------------------------------------- /external/id_dist/src/idzr_aid.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine idzr_aid computes the ID, to a specified rank, 5 | c of an arbitrary matrix. This routine is randomized. 6 | c 7 | c routine idzr_aidi initializes routine idzr_aid. 8 | c 9 | c 10 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 11 | c 12 | c 13 | c 14 | c 15 | subroutine idzr_aid(m,n,a,krank,w,list,proj) 16 | c 17 | c computes the ID of the matrix a, i.e., lists in list 18 | c the indices of krank columns of a such that 19 | c 20 | c a(j,list(k)) = a(j,list(k)) 21 | c 22 | c for all j = 1, ..., m; k = 1, ..., krank, and 23 | c 24 | c min(m,n,krank) 25 | c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) 26 | c l=1 27 | c 28 | c + epsilon(j,k-krank) 29 | c 30 | c for all j = 1, ..., m; k = krank+1, ..., n, 31 | c 32 | c for some matrix epsilon, dimensioned epsilon(m,n-krank), 33 | c whose norm is (hopefully) minimized by the pivoting procedure. 34 | c 35 | c input: 36 | c m -- number of rows in a 37 | c n -- number of columns in a 38 | c a -- matrix to be ID'd; the present routine does not alter a 39 | c krank -- rank of the ID to be constructed 40 | c w -- initialization array that routine idzr_aidi 41 | c has constructed 42 | c 43 | c output: 44 | c list -- indices of the columns in the ID 45 | c proj -- matrix of coefficients needed to interpolate 46 | c from the selected columns to the other columns 47 | c in the original matrix being ID'd 48 | c 49 | c _N.B._: The algorithm used by this routine is randomized. 50 | c 51 | c reference: 52 | c Halko, Martinsson, Tropp, "Finding structure with randomness: 53 | c probabilistic algorithms for constructing approximate 54 | c matrix decompositions," SIAM Review, 53 (2): 217-288, 55 | c 2011. 56 | c 57 | implicit none 58 | integer m,n,krank,list(n),lw,ir,lr,lw2,iw 59 | complex*16 a(m,n),proj(krank*(n-krank)), 60 | 1 w((2*krank+17)*n+21*m+80) 61 | c 62 | c 63 | c Allocate memory in w. 64 | c 65 | lw = 0 66 | c 67 | iw = lw+1 68 | lw2 = 21*m+80+n 69 | lw = lw+lw2 70 | c 71 | ir = lw+1 72 | lr = (krank+8)*2*n 73 | lw = lw+lr 74 | c 75 | c 76 | call idzr_aid0(m,n,a,krank,w(iw),list,proj,w(ir)) 77 | c 78 | c 79 | return 80 | end 81 | c 82 | c 83 | c 84 | c 85 | subroutine idzr_aid0(m,n,a,krank,w,list,proj,r) 86 | c 87 | c routine idzr_aid serves as a memory wrapper 88 | c for the present routine 89 | c (see idzr_aid for further documentation). 90 | c 91 | implicit none 92 | integer k,l,m,n2,n,krank,list(n),mn,lproj 93 | complex*16 a(m,n),r(krank+8,2*n),proj(krank,n-krank), 94 | 1 w(21*m+80+n) 95 | c 96 | c Please note that the second dimension of r is 2*n 97 | c (instead of n) so that if krank+8 >= m/2, then 98 | c we can copy the whole of a into r. 99 | c 100 | c 101 | c Retrieve the number of random test vectors 102 | c and the greatest integer less than m that is 103 | c a positive integer power of two. 104 | c 105 | l = w(1) 106 | n2 = w(2) 107 | c 108 | c 109 | if(l .lt. n2 .and. l .le. m) then 110 | c 111 | c Apply the random matrix. 112 | c 113 | do k = 1,n 114 | call idz_sfrm(l,m,n2,w(11),a(1,k),r(1,k)) 115 | enddo ! k 116 | c 117 | c ID r. 118 | c 119 | call idzr_id(l,n,r,krank,list,w(20*m+81)) 120 | c 121 | c Retrieve proj from r. 122 | c 123 | lproj = krank*(n-krank) 124 | call idzr_copyzarr(lproj,r,proj) 125 | c 126 | endif 127 | c 128 | c 129 | if(l .ge. n2 .or. l .gt. m) then 130 | c 131 | c ID a directly. 132 | c 133 | mn = m*n 134 | call idzr_copyzarr(mn,a,r) 135 | call idzr_id(m,n,r,krank,list,w(20*m+81)) 136 | c 137 | c Retrieve proj from r. 138 | c 139 | lproj = krank*(n-krank) 140 | call idzr_copyzarr(lproj,r,proj) 141 | c 142 | endif 143 | c 144 | c 145 | return 146 | end 147 | c 148 | c 149 | c 150 | c 151 | subroutine idzr_copyzarr(n,a,b) 152 | c 153 | c copies a into b. 154 | c 155 | c input: 156 | c n -- length of a and b 157 | c a -- array to copy into b 158 | c 159 | c output: 160 | c b -- copy of a 161 | c 162 | implicit none 163 | integer n,k 164 | complex*16 a(n),b(n) 165 | c 166 | c 167 | do k = 1,n 168 | b(k) = a(k) 169 | enddo ! k 170 | c 171 | c 172 | return 173 | end 174 | c 175 | c 176 | c 177 | c 178 | subroutine idzr_aidi(m,n,krank,w) 179 | c 180 | c initializes the array w for using routine idzr_aid. 181 | c 182 | c input: 183 | c m -- number of rows in the matrix to be ID'd 184 | c n -- number of columns in the matrix to be ID'd 185 | c krank -- rank of the ID to be constructed 186 | c 187 | c output: 188 | c w -- initialization array for using routine idzr_aid 189 | c 190 | implicit none 191 | integer m,n,krank,l,n2 192 | complex*16 w((2*krank+17)*n+21*m+80) 193 | c 194 | c 195 | c Set the number of random test vectors to 8 more than the rank. 196 | c 197 | l = krank+8 198 | w(1) = l 199 | c 200 | c 201 | c Initialize the rest of the array w. 202 | c 203 | n2 = 0 204 | if(l .le. m) call idz_sfrmi(l,m,n2,w(11)) 205 | w(2) = n2 206 | c 207 | c 208 | return 209 | end 210 | -------------------------------------------------------------------------------- /external/id_dist/src/idzr_asvd.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine idzr_aid computes the SVD, to a specified rank, 5 | c of an arbitrary matrix. This routine is randomized. 6 | c 7 | c 8 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 9 | c 10 | c 11 | c 12 | c 13 | subroutine idzr_asvd(m,n,a,krank,w,u,v,s,ier) 14 | c 15 | c constructs a rank-krank SVD u diag(s) v^* approximating a, 16 | c where u is an m x krank matrix whose columns are orthonormal, 17 | c v is an n x krank matrix whose columns are orthonormal, 18 | c and diag(s) is a diagonal krank x krank matrix whose entries 19 | c are all nonnegative. This routine uses a randomized algorithm. 20 | c 21 | c input: 22 | c m -- number of rows in a 23 | c n -- number of columns in a 24 | c a -- matrix to be decomposed; the present routine does not 25 | c alter a 26 | c krank -- rank of the SVD being constructed 27 | c w -- initialization array that routine idzr_aidi 28 | c has constructed (for use in the present routine, 29 | c w must be at least 30 | c (2*krank+22)*m+(6*krank+21)*n+8*krank**2+10*krank+90 31 | c complex*16 elements long) 32 | c 33 | c output: 34 | c u -- matrix of orthonormal left singular vectors of a 35 | c v -- matrix of orthonormal right singular vectors of a 36 | c s -- array of singular values of a 37 | c ier -- 0 when the routine terminates successfully; 38 | c nonzero otherwise 39 | c 40 | c _N.B._: The algorithm used by this routine is randomized. 41 | c 42 | implicit none 43 | integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, 44 | 1 iwork,lwork,iwinit,lwinit,ier 45 | real*8 s(krank) 46 | complex*16 a(m,n),u(m,krank),v(n,krank), 47 | 1 w((2*krank+22)*m+(6*krank+21)*n+8*krank**2 48 | 2 +10*krank+90) 49 | c 50 | c 51 | c Allocate memory in w. 52 | c 53 | lw = 0 54 | c 55 | iwinit = lw+1 56 | lwinit = (2*krank+17)*n+21*m+80 57 | lw = lw+lwinit 58 | c 59 | ilist = lw+1 60 | llist = n 61 | lw = lw+llist 62 | c 63 | iproj = lw+1 64 | lproj = krank*(n-krank) 65 | lw = lw+lproj 66 | c 67 | icol = lw+1 68 | lcol = m*krank 69 | lw = lw+lcol 70 | c 71 | iwork = lw+1 72 | lwork = (krank+1)*(m+3*n+10)+9*krank**2 73 | lw = lw+lwork 74 | c 75 | c 76 | call idzr_asvd0(m,n,a,krank,w(iwinit),u,v,s,ier, 77 | 1 w(ilist),w(iproj),w(icol),w(iwork)) 78 | c 79 | c 80 | return 81 | end 82 | c 83 | c 84 | c 85 | c 86 | subroutine idzr_asvd0(m,n,a,krank,winit,u,v,s,ier, 87 | 1 list,proj,col,work) 88 | c 89 | c routine idzr_asvd serves as a memory wrapper 90 | c for the present routine (please see routine idzr_asvd 91 | c for further documentation). 92 | c 93 | implicit none 94 | integer m,n,krank,list(n),ier 95 | real*8 s(krank) 96 | complex*16 a(m,n),u(m,krank),v(n,krank), 97 | 1 proj(krank,n-krank),col(m*krank), 98 | 2 winit((2*krank+17)*n+21*m+80), 99 | 3 work((krank+1)*(m+3*n+10)+9*krank**2) 100 | c 101 | c 102 | c ID a. 103 | c 104 | call idzr_aid(m,n,a,krank,winit,list,proj) 105 | c 106 | c 107 | c Collect together the columns of a indexed by list into col. 108 | c 109 | call idz_copycols(m,n,a,krank,list,col) 110 | c 111 | c 112 | c Convert the ID to an SVD. 113 | c 114 | call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) 115 | c 116 | c 117 | return 118 | end 119 | -------------------------------------------------------------------------------- /external/id_dist/src/idzr_rid.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine idzr_rid computes the ID, to a specified rank, 5 | c of a matrix specified by a routine for applying its adjoint 6 | c to arbitrary vectors. This routine is randomized. 7 | c 8 | c 9 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 10 | c 11 | c 12 | c 13 | c 14 | subroutine idzr_rid(m,n,matveca,p1,p2,p3,p4,krank,list,proj) 15 | c 16 | c computes the ID of a matrix "a" specified by 17 | c the routine matveca -- matveca must apply the adjoint 18 | c of the matrix being ID'd to an arbitrary vector -- 19 | c i.e., the present routine lists in list the indices 20 | c of krank columns of a such that 21 | c 22 | c a(j,list(k)) = a(j,list(k)) 23 | c 24 | c for all j = 1, ..., m; k = 1, ..., krank, and 25 | c 26 | c min(m,n,krank) 27 | c a(j,list(k)) = Sigma a(j,list(l)) * proj(l,k-krank)(*) 28 | c l=1 29 | c 30 | c + epsilon(j,k-krank) 31 | c 32 | c for all j = 1, ..., m; k = krank+1, ..., n, 33 | c 34 | c for some matrix epsilon, dimensioned epsilon(m,n-krank), 35 | c whose norm is (hopefully) minimized by the pivoting procedure. 36 | c 37 | c input: 38 | c m -- number of rows in the matrix to be ID'd 39 | c n -- number of columns in the matrix to be ID'd 40 | c matveca -- routine which applies the adjoint 41 | c of the matrix to be ID'd to an arbitrary vector; 42 | c this routine must have a calling sequence 43 | c of the form 44 | c 45 | c matveca(m,x,n,y,p1,p2,p3,p4), 46 | c 47 | c where m is the length of x, 48 | c x is the vector to which the adjoint 49 | c of the matrix is to be applied, 50 | c n is the length of y, 51 | c y is the product of the adjoint of the matrix and x, 52 | c and p1, p2, p3, and p4 are user-specified parameters 53 | c p1 -- parameter to be passed to routine matveca 54 | c p2 -- parameter to be passed to routine matveca 55 | c p3 -- parameter to be passed to routine matveca 56 | c p4 -- parameter to be passed to routine matveca 57 | c krank -- rank of the ID to be constructed 58 | c 59 | c output: 60 | c list -- indices of the columns in the ID 61 | c proj -- matrix of coefficients needed to interpolate 62 | c from the selected columns to the other columns 63 | c in the original matrix being ID'd; 64 | c proj doubles as a work array in the present routine, so 65 | c proj must be at least m+(krank+3)*n complex*16 elements 66 | c long 67 | c 68 | c _N.B._: The algorithm used by this routine is randomized. 69 | c proj must be at least m+(krank+3)*n complex*16 elements 70 | c long. 71 | c 72 | c reference: 73 | c Halko, Martinsson, Tropp, "Finding structure with randomness: 74 | c probabilistic algorithms for constructing approximate 75 | c matrix decompositions," SIAM Review, 53 (2): 217-288, 76 | c 2011. 77 | c 78 | implicit none 79 | integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr 80 | complex*16 p1,p2,p3,p4,proj(m+(krank+3)*n) 81 | external matveca 82 | c 83 | c 84 | c Allocate memory in w. 85 | c 86 | lw = 0 87 | c 88 | ir = lw+1 89 | lr = (krank+2)*n 90 | lw = lw+lr 91 | c 92 | ix = lw+1 93 | lx = m 94 | lw = lw+lx 95 | c 96 | iy = lw+1 97 | ly = n 98 | lw = lw+ly 99 | c 100 | c 101 | call idzr_ridall0(m,n,matveca,p1,p2,p3,p4,krank, 102 | 1 list,proj(ir),proj(ix),proj(iy)) 103 | c 104 | c 105 | return 106 | end 107 | c 108 | c 109 | c 110 | c 111 | subroutine idzr_ridall0(m,n,matveca,p1,p2,p3,p4,krank, 112 | 1 list,r,x,y) 113 | c 114 | c routine idzr_ridall serves as a memory wrapper 115 | c for the present routine 116 | c (see idzr_ridall for further documentation). 117 | c 118 | implicit none 119 | integer j,k,l,m,n,krank,list(n),m2 120 | complex*16 x(m),y(n),p1,p2,p3,p4,r(krank+2,n) 121 | external matveca 122 | c 123 | c 124 | c Set the number of random test vectors to 2 more than the rank. 125 | c 126 | l = krank+2 127 | c 128 | c Apply the adjoint of the original matrix to l random vectors. 129 | c 130 | do j = 1,l 131 | c 132 | c Generate a random vector. 133 | c 134 | m2 = m*2 135 | call id_srand(m2,x) 136 | c 137 | c Apply the adjoint of the matrix to x, obtaining y. 138 | c 139 | call matveca(m,x,n,y,p1,p2,p3,p4) 140 | c 141 | c Copy the conjugate of y into row j of r. 142 | c 143 | do k = 1,n 144 | r(j,k) = conjg(y(k)) 145 | enddo ! k 146 | c 147 | enddo ! j 148 | c 149 | c 150 | c ID r. 151 | c 152 | call idzr_id(l,n,r,krank,list,y) 153 | c 154 | c 155 | return 156 | end 157 | -------------------------------------------------------------------------------- /external/id_dist/src/idzr_rsvd.f: -------------------------------------------------------------------------------- 1 | c this file contains the following user-callable routines: 2 | c 3 | c 4 | c routine idzr_rsvd computes the SVD, to a specified rank, 5 | c of a matrix specified by routines for applying the matrix 6 | c and its adjoint to arbitrary vectors. 7 | c This routine is randomized. 8 | c 9 | c 10 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 11 | c 12 | c 13 | c 14 | c 15 | subroutine idzr_rsvd(m,n,matveca,p1t,p2t,p3t,p4t, 16 | 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier,w) 17 | c 18 | c constructs a rank-krank SVD u diag(s) v^* approximating a, 19 | c where matveca is a routine which applies a^* 20 | c to an arbitrary vector, and matvec is a routine 21 | c which applies a to an arbitrary vector; 22 | c u is an m x krank matrix whose columns are orthonormal, 23 | c v is an n x krank matrix whose columns are orthonormal, 24 | c and diag(s) is a diagonal krank x krank matrix whose entries 25 | c are all nonnegative. This routine uses a randomized algorithm. 26 | c 27 | c input: 28 | c m -- number of rows in a 29 | c n -- number of columns in a 30 | c matveca -- routine which applies the adjoint 31 | c of the matrix to be SVD'd 32 | c to an arbitrary vector; this routine must have 33 | c a calling sequence of the form 34 | c 35 | c matveca(m,x,n,y,p1t,p2t,p3t,p4t), 36 | c 37 | c where m is the length of x, 38 | c x is the vector to which the adjoint 39 | c of the matrix is to be applied, 40 | c n is the length of y, 41 | c y is the product of the adjoint of the matrix and x, 42 | c and p1t, p2t, p3t, and p4t are user-specified 43 | c parameters 44 | c p1t -- parameter to be passed to routine matveca 45 | c p2t -- parameter to be passed to routine matveca 46 | c p3t -- parameter to be passed to routine matveca 47 | c p4t -- parameter to be passed to routine matveca 48 | c matvec -- routine which applies the matrix to be SVD'd 49 | c to an arbitrary vector; this routine must have 50 | c a calling sequence of the form 51 | c 52 | c matvec(n,x,m,y,p1,p2,p3,p4), 53 | c 54 | c where n is the length of x, 55 | c x is the vector to which the matrix is to be applied, 56 | c m is the length of y, 57 | c y is the product of the matrix and x, 58 | c and p1, p2, p3, and p4 are user-specified parameters 59 | c p1 -- parameter to be passed to routine matvec 60 | c p2 -- parameter to be passed to routine matvec 61 | c p3 -- parameter to be passed to routine matvec 62 | c p4 -- parameter to be passed to routine matvec 63 | c krank -- rank of the SVD being constructed 64 | c 65 | c output: 66 | c u -- matrix of orthonormal left singular vectors of a 67 | c v -- matrix of orthonormal right singular vectors of a 68 | c s -- array of singular values of a 69 | c ier -- 0 when the routine terminates successfully; 70 | c nonzero otherwise 71 | c 72 | c work: 73 | c w -- must be at least (krank+1)*(2*m+4*n+10)+8*krank**2 74 | c complex*16 elements long 75 | c 76 | c _N.B._: The algorithm used by this routine is randomized. 77 | c 78 | implicit none 79 | integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol, 80 | 1 iwork,lwork,ier 81 | real*8 s(krank) 82 | complex*16 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), 83 | 1 w((krank+1)*(2*m+4*n+10)+8*krank**2) 84 | external matveca,matvec 85 | c 86 | c 87 | c Allocate memory in w. 88 | c 89 | lw = 0 90 | c 91 | ilist = lw+1 92 | llist = n 93 | lw = lw+llist 94 | c 95 | iproj = lw+1 96 | lproj = krank*(n-krank) 97 | lw = lw+lproj 98 | c 99 | icol = lw+1 100 | lcol = m*krank 101 | lw = lw+lcol 102 | c 103 | iwork = lw+1 104 | lwork = (krank+1)*(m+3*n+10)+9*krank**2 105 | lw = lw+lwork 106 | c 107 | c 108 | call idzr_rsvd0(m,n,matveca,p1t,p2t,p3t,p4t, 109 | 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, 110 | 2 w(ilist),w(iproj),w(icol),w(iwork)) 111 | c 112 | c 113 | return 114 | end 115 | c 116 | c 117 | c 118 | c 119 | subroutine idzr_rsvd0(m,n,matveca,p1t,p2t,p3t,p4t, 120 | 1 matvec,p1,p2,p3,p4,krank,u,v,s,ier, 121 | 2 list,proj,col,work) 122 | c 123 | c routine idzr_rsvd serves as a memory wrapper 124 | c for the present routine (please see routine idzr_rsvd 125 | c for further documentation). 126 | c 127 | implicit none 128 | integer m,n,krank,list(n),ier,k 129 | real*8 s(krank) 130 | complex*16 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank), 131 | 1 proj(krank*(n-krank)),col(m*krank), 132 | 2 work((krank+1)*(m+3*n+10)+9*krank**2) 133 | external matveca,matvec 134 | c 135 | c 136 | c ID a. 137 | c 138 | call idzr_rid(m,n,matveca,p1t,p2t,p3t,p4t,krank,list,work) 139 | c 140 | c 141 | c Retrieve proj from work. 142 | c 143 | do k = 1,krank*(n-krank) 144 | proj(k) = work(k) 145 | enddo ! k 146 | c 147 | c 148 | c Collect together the columns of a indexed by list into col. 149 | c 150 | call idz_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work) 151 | c 152 | c 153 | c Convert the ID to an SVD. 154 | c 155 | call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work) 156 | c 157 | c 158 | return 159 | end 160 | -------------------------------------------------------------------------------- /external/id_dist/src/prini.f: -------------------------------------------------------------------------------- 1 | C 2 | C 3 | C 4 | C 5 | SUBROUTINE PRINI(IP1,IQ1) 6 | save 7 | CHARACTER *1 MES(1), AA(1) 8 | REAL *4 A(1) 9 | REAL *8 A2(1) 10 | REAL *8 A4(1) 11 | INTEGER *4 IA(1) 12 | INTEGER *2 IA2(1) 13 | IP=IP1 14 | IQ=IQ1 15 | 16 | RETURN 17 | 18 | C 19 | C 20 | C 21 | C 22 | C 23 | ENTRY PRIN(MES,A,N) 24 | CALL MESSPR(MES,IP,IQ) 25 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1200)(A(J),J=1,N) 26 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1200)(A(J),J=1,N) 27 | 1200 FORMAT(6(2X,E11.5)) 28 | RETURN 29 | C 30 | C 31 | C 32 | C 33 | ENTRY PRIN2(MES,A2,N) 34 | CALL MESSPR(MES,IP,IQ) 35 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1400)(A2(J),J=1,N) 36 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1400)(A2(J),J=1,N) 37 | 1400 FORMAT(6(2X,E11.5)) 38 | RETURN 39 | C 40 | C 41 | C 42 | C 43 | ENTRY PRIN2_long(MES,A2,N) 44 | CALL MESSPR(MES,IP,IQ) 45 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1450)(A2(J),J=1,N) 46 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1450)(A2(J),J=1,N) 47 | 1450 FORMAT(2(2X,E22.16)) 48 | RETURN 49 | C 50 | C 51 | C 52 | C 53 | ENTRY PRINQ(MES,A4,N) 54 | CALL MESSPR(MES,IP,IQ) 55 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1500)(A4(J),J=1,N) 56 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1500)(A4(J),J=1,N) 57 | 1500 FORMAT(6(2X,e11.5)) 58 | RETURN 59 | C 60 | C 61 | C 62 | C 63 | ENTRY PRINF(MES,IA,N) 64 | CALL MESSPR(MES,IP,IQ) 65 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1600)(IA(J),J=1,N) 66 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1600)(IA(J),J=1,N) 67 | 1600 FORMAT(10(1X,I7)) 68 | RETURN 69 | C 70 | C 71 | C 72 | C 73 | ENTRY PRINF2(MES,IA2,N) 74 | CALL MESSPR(MES,IP,IQ) 75 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,1600)(IA2(J),J=1,N) 76 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,1600)(IA2(J),J=1,N) 77 | RETURN 78 | C 79 | C 80 | C 81 | C 82 | ENTRY PRINA(MES,AA,N) 83 | CALL MESSPR(MES,IP,IQ) 84 | 2000 FORMAT(1X,80A1) 85 | IF(IP.NE.0 .AND. N.NE.0) WRITE(IP,2000)(AA(J),J=1,N) 86 | IF(IQ.NE.0 .AND. N.NE.0) WRITE(IQ,2000)(AA(J),J=1,N) 87 | RETURN 88 | END 89 | c 90 | c 91 | c 92 | c 93 | c 94 | SUBROUTINE MESSPR(MES,IP,IQ) 95 | save 96 | CHARACTER *1 MES(1),AST 97 | DATA AST/'*'/ 98 | C 99 | C DETERMINE THE LENGTH OF THE MESSAGE 100 | C 101 | I1=0 102 | DO 1400 I=1,10000 103 | IF(MES(I).EQ.AST) GOTO 1600 104 | I1=I 105 | 1400 CONTINUE 106 | 1600 CONTINUE 107 | IF ( (I1.NE.0) .AND. (IP.NE.0) ) 108 | 1 WRITE(IP,1800) (MES(I),I=1,I1) 109 | IF ( (I1.NE.0) .AND. (IQ.NE.0) ) 110 | 1 WRITE(IQ,1800) (MES(I),I=1,I1) 111 | 1800 FORMAT(1X,80A1) 112 | RETURN 113 | END 114 | C 115 | C 116 | C 117 | C 118 | C 119 | SUBROUTINE ZTIME(I) 120 | save 121 | J=1 122 | J=7-I+J 123 | CCCC I=MRUN(J) 124 | RETURN 125 | END 126 | c 127 | c 128 | c 129 | c 130 | c 131 | subroutine msgmerge(a,b,c) 132 | save 133 | character *1 a(1),b(1),c(1),ast 134 | data ast/'*'/ 135 | c 136 | do 1200 i=1,1000 137 | c 138 | if(a(i) .eq. ast) goto 1400 139 | c(i)=a(i) 140 | iadd=i 141 | 1200 continue 142 | c 143 | 1400 continue 144 | c 145 | do 1800 i=1,1000 146 | c 147 | c(iadd+i)=b(i) 148 | if(b(i) .eq. ast) return 149 | 1800 continue 150 | return 151 | end 152 | c 153 | c 154 | c 155 | c 156 | c 157 | 158 | subroutine fileflush(iw) 159 | implicit real *8 (a-h,o-z) 160 | c 161 | save 162 | close(iw) 163 | open(iw,status='old') 164 | do 1400 i=1,1000000 165 | c 166 | read(iw,1200,end=1600) 167 | 1200 format(1a1) 168 | 1400 continue 169 | 1600 continue 170 | c 171 | return 172 | end 173 | 174 | 175 | c 176 | c 177 | c 178 | c 179 | c 180 | subroutine mach_zero(zero_mach) 181 | implicit real *8 (a-h,o-z) 182 | save 183 | c 184 | zero_mach=100 185 | c 186 | d1=1.1 187 | d3=1.1 188 | d=1.11 189 | do 1200 i=1,1000 190 | c 191 | 192 | d=d/2 193 | d2=d1+d 194 | call mach_zero0(d2,d3,d4) 195 | c 196 | if(d4 .eq. 0) goto 1400 197 | c 198 | 1200 continue 199 | 1400 continue 200 | c 201 | zero_mach=d 202 | return 203 | end 204 | 205 | c 206 | c 207 | c 208 | c 209 | c 210 | subroutine mach_zero0(a,b,c) 211 | implicit real *8 (a-h,o-z) 212 | save 213 | c 214 | c=b-a 215 | 216 | return 217 | end 218 | -------------------------------------------------------------------------------- /external/id_dist/test/id_rand_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 5 000 000) 10 | c 11 | integer n,k,m,ind(len) 12 | real*8 r(len),s(55),temp,r2(len),diff 13 | c 14 | data s/ 15 | 1 0.2793574644042651d0, 0.1882566493961346d0, 16 | 2 0.5202478134503912d0, 0.7568505373052146d0, 17 | 3 0.5682465992936152d0, 0.5153148754383294d0, 18 | 4 0.7806554095454596d0, 1.982474428974643d-2, 19 | 5 0.2520464262278498d0, 0.6423784715775962d0, 20 | 6 0.5802024387972178d0, 0.3784471040388249d0, 21 | 7 7.839919528229308d-2, 0.6334519212594525d0, 22 | 8 3.387627157788001d-2, 0.1709066283884670d0, 23 | 9 0.4801610983518325d0, 0.8983424668099422d0, 24 | * 5.358948687598758d-2, 0.1265377231771848d0, 25 | 1 0.8979988627693677d0, 0.6470084038238917d0, 26 | 2 0.3031709395541237d0, 0.6674702804438126d0, 27 | 3 0.6318240977112699d0, 0.2235229633873050d0, 28 | 4 0.2784629939177633d0, 0.2365462014457445d0, 29 | 5 0.7226213454977284d0, 0.8986523045307989d0, 30 | 6 0.5488233229247885d0, 0.3924605412141200d0, 31 | 7 0.6288356378374988d0, 0.6370664115760445d0, 32 | 8 0.5925600062791174d0, 0.4322113919396362d0, 33 | 9 0.9766098520360393d0, 0.5168619893947437d0, 34 | * 0.6799970440779681d0, 0.4196004604766881d0, 35 | 1 0.2324473089903044d0, 0.1439046416143282d0, 36 | 2 0.4670307948601256d0, 0.7076498261128343d0, 37 | 3 0.9458030397562582d0, 0.4557892460080424d0, 38 | 4 0.3905930854589403d0, 0.3361770064397268d0, 39 | 5 0.8303274937900278d0, 0.3041110304032945d0, 40 | 6 0.5752684022049654d0, 7.985703137991175d-2, 41 | 7 0.5522643936454465d0, 1.956754937251801d-2, 42 | 8 0.9920272858340107d0/ 43 | c 44 | c 45 | call prini(6,13) 46 | c 47 | c 48 | print *,'Enter n:' 49 | read *,n 50 | call prinf('n = *',n,1) 51 | c 52 | c 53 | c Generate n random numbers uniformly drawn from [0,1]. 54 | c 55 | call id_frand(n,r) 56 | call prin2('r = *',r,n) 57 | c 58 | c Generate n more random numbers uniformly drawn from [0,1]. 59 | c 60 | call id_frand(n,r) 61 | call prin2('r = *',r,n) 62 | c 63 | c Initialize the seed values in id_frand 64 | c to their original values. 65 | c 66 | call id_frando() 67 | c 68 | c Generate n more random numbers uniformly drawn from [0,1]. 69 | c 70 | call id_frand(n,r) 71 | call prin2('r = *',r,n) 72 | c 73 | c 74 | c Print the percentiles of r. 75 | c 76 | m = 10 77 | call histogram(n,r,m) 78 | c 79 | c 80 | c Reverse the order of the seed values in s. 81 | c 82 | do k = 1,55/2 83 | temp = s(k) 84 | s(k) = s(55-k+1) 85 | s(55-k+1) = temp 86 | enddo ! k 87 | c 88 | c 89 | c Generate r2 using id_srand so that it should match r 90 | c generated using id_frand. 91 | c 92 | call id_srandi(s) 93 | call id_srand(n,r2) 94 | c 95 | c 96 | c Compute and print the difference between r and r2. 97 | c 98 | diff = 0 99 | c 100 | do k = 1,n 101 | diff = diff+abs(r(k)-r2(k)) 102 | enddo ! k 103 | c 104 | call prin2('diff = *',diff,1) 105 | c 106 | c 107 | c Generate and display a random permutation. 108 | c 109 | call id_randperm(n,ind) 110 | call prinf('ind = *',ind,n) 111 | c 112 | c 113 | stop 114 | end 115 | c 116 | c 117 | c 118 | c 119 | subroutine histogram(n,r,m) 120 | c 121 | c counts and prints the number of entries of r falling 122 | c into m equally wide bins partitioning [0,1]. 123 | c 124 | c input: 125 | c n -- length of r 126 | c r -- array to be binned 127 | c m -- number of bins 128 | c 129 | implicit none 130 | integer m,n,nbin,j,k,iarr(2) 131 | real*8 r(n),width,r1 132 | c 133 | r1 = 1 134 | c 135 | c 136 | width = r1/m 137 | c 138 | c 139 | do j = 1,m 140 | c 141 | nbin = 0 142 | c 143 | do k = 1,n 144 | c 145 | if(r(k) .gt. (j-1)*width .and. r(k) .le. j*width) 146 | 1 nbin = nbin+1 147 | c 148 | enddo ! k 149 | c 150 | iarr(1) = j 151 | iarr(2) = nbin 152 | call prinf('(j,nbin) = *',iarr,2) 153 | c 154 | enddo ! j 155 | c 156 | c 157 | return 158 | end 159 | c 160 | c 161 | c 162 | c 163 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 164 | c 165 | c 166 | c The above code is for testing and debugging; the remainder of 167 | c this file contains the following user-callable routines: 168 | -------------------------------------------------------------------------------- /external/id_dist/test/id_rtrans_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, id_rand 4 | c 5 | c 6 | implicit real *8 (a-h,o-z) 7 | c 8 | call prini(6,13) 9 | c 10 | c set all parameters 11 | c 12 | print *, 'Enter n:' 13 | read *,n 14 | call prinf('n=*',n,1) 15 | c 16 | call lams_test(n) 17 | call lams_test_complex(n) 18 | c 19 | stop 20 | end 21 | c 22 | c 23 | c 24 | c 25 | c 26 | subroutine lams_test_complex(n) 27 | implicit real *8 (a-h,o-z) 28 | save 29 | complex *16 w(1000 000),x(1000 000),y(1000 000),z(1000 000) 30 | c 31 | c tests the complex-valued random transformations. 32 | c 33 | c input: 34 | c n -- size of transform to be tested 35 | c 36 | c construct the input vector 37 | c 38 | do 1200 i=1,n 39 | c 40 | x(i)=i 41 | 1200 continue 42 | c 43 | nsteps=10 44 | c 45 | c apply the operator 46 | c 47 | call idz_random_transf_init(nsteps,n,w,keep) 48 | call idz_random_transf(x,y,w) 49 | c 50 | call prin2('x=*',x,n*2) 51 | call prin2('y=*',y,n*2) 52 | c 53 | c apply inverse operator 54 | c 55 | call idz_random_transf_inverse(y,z,w) 56 | call prin2('and z=*',z,n*2) 57 | c 58 | return 59 | end 60 | c 61 | c 62 | c 63 | c 64 | c 65 | subroutine lams_test(n) 66 | implicit real *8 (a-h,o-z) 67 | save 68 | dimension w(1000 000),x(1000 000),y(1000 000),z(1000 000) 69 | c 70 | c tests the real-valued random transformations. 71 | c 72 | c input: 73 | c n -- size of transform to be tested 74 | c 75 | c construct the input vector 76 | c 77 | do 1200 i=1,n 78 | c 79 | x(i)=i 80 | 1200 continue 81 | c 82 | nsteps=10 83 | c 84 | c apply the operator 85 | c 86 | call idd_random_transf_init(nsteps,n,w,keep) 87 | call idd_random_transf(x,y,w) 88 | c 89 | call prin2('x=*',x,n) 90 | call prin2('y=*',y,n) 91 | c 92 | c apply inverse operator 93 | c 94 | call idd_random_transf_inverse(y,z,w) 95 | call prin2('and z=*',z,n) 96 | c 97 | return 98 | end 99 | c 100 | c 101 | c 102 | c 103 | c 104 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 105 | c 106 | c 107 | c The above code is for testing and debugging; the remainder of 108 | c this file contains the following user-callable routines: 109 | -------------------------------------------------------------------------------- /external/id_dist/test/idd_house_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer n,k,ifrescal 12 | real*8 x(len),vn(len),h(len),c(len),diffmax,difffrob,scal, 13 | 1 y(len),rss,diff1,diffmax2ton,rsshh 14 | c 15 | c 16 | call prini(6,13) 17 | c 18 | c 19 | print *,'Enter n (the length of the vector to reflect ' 20 | 1 //'into its first component): ' 21 | read *,n 22 | call prinf('n = *',n,1) 23 | c 24 | c 25 | c Fill x with something. 26 | c 27 | do k = 1,n 28 | x(k) = -k 29 | enddo ! k 30 | call prin2('x = *',x,n) 31 | c 32 | c 33 | c Calculate the normalized Householder vector vn 34 | c corresponding to x. 35 | c 36 | call idd_house(n,x,rsshh,vn,scal) 37 | call prin2('rsshh = *',rsshh,1) 38 | c 39 | c 40 | c Build the Householder transformation matrix h from vn. 41 | c 42 | call idd_housemat(n,vn,scal,h) 43 | c 44 | c 45 | c Calculate the root-sum-square of the entries of x. 46 | c 47 | call calcrss(n,x,rss) 48 | call prin2('rss = *',rss,1) 49 | c 50 | c 51 | c Apply the Householder matrix for vector vn and scalar scal 52 | c to x, yielding y. 53 | c 54 | ifrescal = 1 55 | call idd_houseapp(n,vn,x,ifrescal,scal,y) 56 | call prin2('y = *',y,n) 57 | c 58 | c 59 | c Check that abs(y(1)) = rss. 60 | c 61 | diff1 = abs( rss-abs(y(1)) ) 62 | diff1 = diff1/rss 63 | call prin2('diff1 = *',diff1,1) 64 | c 65 | c 66 | c Check that y(2) = 0, ..., y(n) = 0. 67 | c 68 | diffmax2ton = 0 69 | c 70 | do k = 2,n 71 | if(abs(y(k)) .gt. diffmax2ton) diffmax2ton = abs(y(k)) 72 | enddo ! k 73 | c 74 | diffmax2ton = diffmax2ton/rss 75 | call prin2('diffmax2ton = *',diffmax2ton,1) 76 | c 77 | c 78 | c Check that h^2 = _1_ 79 | c (h^2 = _1_ because h is both symmetric and orthogonal). 80 | c 81 | call multiply(n,h,h,c) 82 | call checkid(n,c,diffmax,difffrob) 83 | call prin2('diffmax = *',diffmax,1) 84 | call prin2('difffrob = *',difffrob,1) 85 | c 86 | c 87 | stop 88 | end 89 | c 90 | c 91 | c 92 | c 93 | subroutine multiply(n,a,b,c) 94 | c 95 | c multiplies a and b to get c. 96 | c 97 | c input: 98 | c n -- size of a, b, and c 99 | c a -- n x n matrix to be applied to b 100 | c b -- n x n matrix to which a is applied 101 | c 102 | c output: 103 | c c -- matrix resulting from applying a to b 104 | c 105 | implicit none 106 | integer n,j,k,l 107 | real*8 a(n,n),b(n,n),c(n,n) 108 | c 109 | c 110 | do j = 1,n 111 | do l = 1,n 112 | c(j,l) = 0 113 | enddo ! l 114 | enddo ! j 115 | c 116 | do l = 1,n 117 | do j = 1,n 118 | c 119 | do k = 1,n 120 | c(j,l) = c(j,l)+a(k,j)*b(l,k) 121 | enddo ! k 122 | c 123 | enddo ! j 124 | enddo ! l 125 | c 126 | c 127 | return 128 | end 129 | c 130 | c 131 | c 132 | c 133 | subroutine checkid(n,c,diffmax,difffrob) 134 | c 135 | c calculates the difference between c and the identity matrix. 136 | c 137 | c input: 138 | c n -- size of c 139 | c c -- matrix that is supposed to be close to the identity 140 | c 141 | c output: 142 | c diffmax -- maximum entrywise difference 143 | c between c and the identity 144 | c difffrob -- root-sum-square of the entries 145 | c of the matrix identity_matrix - c 146 | c 147 | implicit none 148 | integer n,j,k 149 | real*8 c(n,n),diffmax,difffrob,diff 150 | c 151 | c 152 | diffmax = 0 153 | difffrob = 0 154 | c 155 | do j = 1,n 156 | do k = 1,n 157 | c 158 | if(k .eq. j) diff = abs(1-c(k,j)) 159 | if(k .ne. j) diff = abs(c(k,j)) 160 | c 161 | if(diff .gt. diffmax) diffmax = diff 162 | difffrob = difffrob+diff**2 163 | c 164 | enddo ! k 165 | enddo ! j 166 | c 167 | difffrob = sqrt(difffrob) 168 | c 169 | c 170 | return 171 | end 172 | c 173 | c 174 | c 175 | c 176 | subroutine disp(n,a) 177 | c 178 | c displays the n x n matrix a. 179 | c 180 | c input: 181 | c n -- size of a 182 | c a -- n x n matrix to be written to the output stream 183 | c 184 | implicit none 185 | integer n,k 186 | real*8 a(n,n) 187 | c 188 | c 189 | do k = 1,n 190 | call prin2('*',a(1,k),n) 191 | enddo ! j 192 | c 193 | c 194 | return 195 | end 196 | c 197 | c 198 | c 199 | c 200 | subroutine calcrss(n,v,rss) 201 | c 202 | c calculates the root-sum-square of the entries of v. 203 | c 204 | c input: 205 | c n -- size of v 206 | c v -- vector whose entries are to be root-sum-squared 207 | c 208 | c output: 209 | c rss -- root-sum-square of the entries of v 210 | c 211 | implicit none 212 | integer n,k 213 | real*8 v(n),rss 214 | c 215 | c 216 | rss = 0 217 | do k = 1,n 218 | rss = rss+v(k)**2 219 | enddo ! k 220 | rss = sqrt(rss) 221 | c 222 | c 223 | return 224 | end 225 | c 226 | c 227 | c 228 | c 229 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 230 | c 231 | c 232 | c The above code is for testing and debugging; the remainder of 233 | c this file contains the following user-callable routines: 234 | -------------------------------------------------------------------------------- /external/id_dist/test/idd_id_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,ifdisp 12 | real*8 a(len),a0(len),col(len) 13 | c 14 | c 15 | call prini(6,13) 16 | c 17 | c 18 | print *, 19 | 1 'To display full matrices, enter 1; otherwise, enter 0:' 20 | read *,ifdisp 21 | call prinf('ifdisp = *',ifdisp,1) 22 | c 23 | print *,'Enter m:' 24 | read *,m 25 | call prinf('m = *',m,1) 26 | c 27 | print *,'Enter n:' 28 | read *,n 29 | call prinf('n = *',n,1) 30 | c 31 | c 32 | call check(ifdisp,m,n,a,a0,col) 33 | c 34 | c 35 | stop 36 | end 37 | c 38 | c 39 | c 40 | c 41 | subroutine check(ifdisp,m,n,a,a0,col) 42 | c 43 | implicit none 44 | c 45 | integer len 46 | parameter(len = 1 000 000) 47 | c 48 | integer m,n,j,k,krank,list(len),ifdisp,loop 49 | real*8 a(m,n),r1,pi,work(len),a0(m,n),approx(len), 50 | 1 errmax,errrms,eps,col(m,n) 51 | c 52 | r1 = 1 53 | pi = 4*atan(r1) 54 | c 55 | c 56 | c Fill a0 with something. 57 | c 58 | do k = 1,n 59 | do j = 1,m 60 | a0(j,k) = sin(j*k/(r1*m+1)) 61 | enddo ! j 62 | enddo ! k 63 | c 64 | if(n .ge. 6) then 65 | c 66 | do k = 4,6 67 | do j = 1,m 68 | a0(j,k) = ( a0(j,k-3)+a0(j,1) )/5 69 | enddo ! j 70 | enddo ! k 71 | c 72 | endif 73 | c 74 | if(ifdisp .eq. 1) call rectdisp('a0 = *',a0,m,n) 75 | c 76 | c 77 | do loop = 1,2 78 | c 79 | c 80 | c Duplicate a0 into a. 81 | c 82 | do k = 1,n 83 | do j = 1,m 84 | a(j,k) = a0(j,k) 85 | enddo ! j 86 | enddo ! k 87 | c 88 | c 89 | if(loop .eq. 1) then 90 | c 91 | c 92 | c ID a. 93 | c 94 | eps = .1d-13 95 | c 96 | call iddp_id(eps,m,n,a,krank,list,work) 97 | c 98 | call prinf('krank = *',krank,1) 99 | call prinf('list = *',list,n) 100 | if(ifdisp .eq. 1) 101 | 1 call rectdisp('a (proj) = *',a,krank,n-krank) 102 | c 103 | c 104 | endif ! loop .eq. 1 105 | c 106 | c 107 | if(loop .eq. 2) then 108 | c 109 | c 110 | c ID a. 111 | c 112 | call iddr_id(m,n,a,krank,list,work) 113 | call prinf('list = *',list,n) 114 | if(ifdisp .eq. 1) 115 | 1 call rectdisp('a (proj) = *',a,krank,n-krank) 116 | c 117 | c 118 | endif ! loop .eq. 2 119 | c 120 | c 121 | c Copy the selected columns of a0 into col 122 | c (in the order given by list). 123 | c 124 | call idd_copycols(m,n,a0,krank,list,col) 125 | c 126 | c 127 | c Reconstruct a0 from col and the proj in a. 128 | c 129 | call idd_reconid(m,krank,col,n,list,a,approx) 130 | if(ifdisp .eq. 1) call rectdisp('approx = *',approx,m,n) 131 | c 132 | c 133 | if(krank .gt. 0) then 134 | c 135 | c Calculate the relative maximum and root-mean-square errors 136 | c corresponding to how much a0 and approx differ. 137 | c 138 | call materr(m,n,a0,approx,errmax,errrms) 139 | call prin2('errmax = *',errmax,1) 140 | call prin2('errrms = *',errrms,1) 141 | c 142 | endif 143 | c 144 | c 145 | enddo ! loop 146 | c 147 | c 148 | return 149 | end 150 | c 151 | c 152 | c 153 | c 154 | subroutine materr(m,n,a,b,errmax,errrms) 155 | c 156 | c calculates the relative maximum and root-mean-square errors 157 | c corresponding to how much a and b differ. 158 | c 159 | c input: 160 | c m -- first dimension of a and b 161 | c n -- second dimension of a and b 162 | c a -- matrix whose difference from b will be measured 163 | c b -- matrix whose difference from a will be measured 164 | c 165 | c output: 166 | c errmax -- ratio of the maximum elementwise absolute difference 167 | c between a and b to the maximum magnitude 168 | c of all the elements of a 169 | c errrms -- ratio of the root-mean-square of the elements 170 | c of the difference of a and b to the root-mean-square 171 | c of all the elements of a 172 | c 173 | implicit none 174 | integer m,n,j,k 175 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 176 | c 177 | c 178 | c Calculate the maximum magnitude amax of the elements of a 179 | c and the root-sum-square arss of the elements of a. 180 | c 181 | amax = 0 182 | arss = 0 183 | c 184 | do k = 1,n 185 | do j = 1,m 186 | c 187 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 188 | arss = arss+a(j,k)**2 189 | c 190 | enddo ! j 191 | enddo ! k 192 | c 193 | arss = sqrt(arss) 194 | c 195 | c 196 | c Calculate the maximum elementwise absolute difference 197 | c between a and b, as well as the root-sum-square errrms 198 | c of the elements of the difference of a and b. 199 | c 200 | errmax = 0 201 | errrms = 0 202 | c 203 | do k = 1,n 204 | do j = 1,m 205 | c 206 | diff = abs(a(j,k)-b(j,k)) 207 | c 208 | if(diff .gt. errmax) errmax = diff 209 | errrms = errrms+diff**2 210 | c 211 | enddo ! j 212 | enddo ! k 213 | c 214 | errrms = sqrt(errrms) 215 | c 216 | c 217 | c Calculate relative errors. 218 | c 219 | errmax = errmax/amax 220 | errrms = errrms/arss 221 | c 222 | c 223 | return 224 | end 225 | c 226 | c 227 | c 228 | c 229 | subroutine rectdisp(str,a,m,n) 230 | c 231 | c displays a real rectangular matrix a via prini, 232 | c with the first index of a ascending as you read the rows 233 | c from left to right, 234 | c and the second index of a ascending as you read the columns 235 | c from top to bottom. 236 | c 237 | c input: 238 | c str -- message for prin2 239 | c a -- matrix to display 240 | c m -- first dimension of a 241 | c n -- second dimension of a 242 | c 243 | c _N.B._: You must call prini for initialization 244 | c before calling this routine. 245 | c 246 | implicit none 247 | integer m,n,k 248 | real*8 a(m,n) 249 | character*1 str(1) 250 | c 251 | c 252 | call prin2(str,a,0) 253 | do k = 1,n 254 | call prin2('*',a(1,k),m) 255 | enddo ! k 256 | c 257 | c 258 | return 259 | end 260 | c 261 | c 262 | c 263 | c 264 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 265 | c 266 | c 267 | c The above code is for testing and debugging; the remainder of 268 | c this file contains the following user-callable routines: 269 | -------------------------------------------------------------------------------- /external/id_dist/test/idd_snorm_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,krank,its,k 12 | real*8 snorm,diffsnorm,r1,a(len),dummy, 13 | 1 u(len),v(len),b(len),rnd 14 | external matvec,matvect 15 | c 16 | r1 = 1 17 | c 18 | c 19 | call prini(6,13) 20 | c 21 | c 22 | print *,'Enter m:' 23 | read *,m 24 | call prinf('m = *',m,1) 25 | c 26 | print *,'Enter n:' 27 | read *,n 28 | call prinf('n = *',n,1) 29 | c 30 | krank = 5 31 | call prinf('krank = *',krank,1) 32 | c 33 | c 34 | c Fill a with a matrix whose spectral norm is 2. 35 | c 36 | call fill(krank,m,n,a,u) 37 | c 38 | c 39 | c Calculate the spectral norm of a. 40 | c 41 | its = 100 42 | c 43 | call idd_snorm(m,n,matvect,a,dummy,dummy,dummy, 44 | 1 matvec,a,dummy,dummy,dummy,its,snorm,v,u) 45 | c 46 | c 47 | c Divide snorm by 2 and display it. 48 | c 49 | snorm = snorm/2 50 | call prin2('snorm (which should be 1) = *',snorm,1) 51 | c 52 | c 53 | c Add a little noise to a, obtaining b. 54 | c 55 | do k = 1,m*n 56 | call id_srand(1,rnd) 57 | b(k) = a(k)+.1d-12*rnd 58 | enddo ! k 59 | c 60 | c 61 | c Calculate the spectral norm of a-b. 62 | c 63 | its = 100 64 | c 65 | call idd_diffsnorm(m,n,matvect,a,dummy,dummy,dummy, 66 | 1 matvect,b,dummy,dummy,dummy, 67 | 2 matvec,a,dummy,dummy,dummy, 68 | 3 matvec,b,dummy,dummy,dummy,its,diffsnorm,v) 69 | c 70 | c 71 | c Divide diffsnorm by .5d-13*sqrt(m*n) and display it. 72 | c 73 | diffsnorm = diffsnorm/(.5d-13*sqrt(r1*m*n)) 74 | call prin2('diffsnorm (which should be about 1) = *', 75 | 1 diffsnorm,1) 76 | c 77 | c 78 | stop 79 | end 80 | c 81 | c 82 | c 83 | c 84 | subroutine fill(krank,m,n,a,s) 85 | c 86 | c fills an m x n matrix with suitably decaying singular values, 87 | c and left and right singular vectors taken from the DCT-IV. 88 | c 89 | c input: 90 | c krank -- one less than the rank of the matrix to be constructed 91 | c m -- first dimension of a 92 | c n -- second dimension of a 93 | c 94 | c output: 95 | c a -- filled matrix 96 | c s -- singular values of a 97 | c 98 | implicit none 99 | integer krank,j,k,l,m,n 100 | real*8 r1,pi,a(m,n),sum,s(krank+1) 101 | c 102 | r1 = 1 103 | pi = 4*atan(r1) 104 | c 105 | c 106 | c Specify the singular values. 107 | c 108 | do k = 1,krank 109 | s(k) = exp(log(1d-10)*(k-1)/(krank-1)) 110 | enddo ! k 111 | c 112 | s(krank+1) = 1d-10 113 | c 114 | c 115 | c Construct a. 116 | c 117 | do k = 1,n 118 | do j = 1,m 119 | c 120 | sum = 0 121 | c 122 | do l = 1,krank 123 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 124 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*s(l) 125 | enddo ! l 126 | c 127 | l = krank+1 128 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 129 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*s(l) 130 | c 131 | a(j,k) = sum*2 132 | c 133 | enddo ! j 134 | enddo ! k 135 | c 136 | c 137 | return 138 | end 139 | c 140 | c 141 | c 142 | c 143 | subroutine matvect(m,x,n,y,a,p2,p3,p4) 144 | c 145 | c applies the transpose of a to x, obtaining y. 146 | c 147 | c input: 148 | c m -- first dimension of a, and length of x 149 | c x -- vector to which a^T is to be applied 150 | c n -- second dimension of a, and length of y 151 | c a -- matrix whose transpose is to be applied to x 152 | c in order to create y 153 | c p2 -- dummy input 154 | c p3 -- dummy input 155 | c p4 -- dummy input 156 | c 157 | c output: 158 | c y -- product of a^T and x 159 | c 160 | implicit none 161 | integer m,n,j,k 162 | real*8 a(m,n),p2,p3,p4,x(m),y(n),sum 163 | c 164 | c 165 | do k = 1,n 166 | c 167 | sum = 0 168 | c 169 | do j = 1,m 170 | sum = sum+a(j,k)*x(j) 171 | enddo ! j 172 | c 173 | y(k) = sum 174 | c 175 | enddo ! k 176 | c 177 | c 178 | return 179 | end 180 | c 181 | c 182 | c 183 | c 184 | subroutine matvec(n,x,m,y,a,p2,p3,p4) 185 | c 186 | c applies a to x, obtaining y. 187 | c 188 | c input: 189 | c m -- first dimension of a, and length of x 190 | c x -- vector to which a is to be applied 191 | c n -- second dimension of a, and length of y 192 | c a -- matrix to be applied to x in order to create y 193 | c p2 -- dummy input 194 | c p3 -- dummy input 195 | c p4 -- dummy input 196 | c 197 | c output: 198 | c y -- product of a and x 199 | c 200 | implicit none 201 | integer m,n,j,k 202 | real*8 a(m,n),p2,p3,p4,x(n),y(m),sum 203 | c 204 | c 205 | do j = 1,m 206 | c 207 | sum = 0 208 | c 209 | do k = 1,n 210 | sum = sum+a(j,k)*x(k) 211 | enddo ! k 212 | c 213 | y(j) = sum 214 | c 215 | enddo ! j 216 | c 217 | c 218 | return 219 | end 220 | c 221 | c 222 | c 223 | c 224 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 225 | c 226 | c 227 | c The above code is for testing and debugging; the remainder of 228 | c this file contains the following user-callable routines: 229 | -------------------------------------------------------------------------------- /external/id_dist/test/iddp_aid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv, idd_id, id_rand, 4 | c idd_sfft, id_rtrans, idd_frm, dfft 5 | c 6 | c 7 | implicit none 8 | c 9 | integer len 10 | parameter(len = 1 000 000) 11 | c 12 | integer m,n,krank,list(len),n2 13 | real*8 a(len),eps,col(len),work(len), 14 | 1 errmax,errrms,proj(len),b(len) 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | c 36 | c 37 | c Initialize the array work for use in iddp_aid. 38 | c 39 | call idd_frmi(m,n2,work) 40 | c 41 | c 42 | c ID a via a randomized algorithm. 43 | c 44 | eps = .1d-10 45 | call iddp_aid(eps,m,n,a,work,krank,list,proj) 46 | call prinf('list = *',list,krank) 47 | c 48 | c 49 | c Collect together the columns of a indexed by list into col. 50 | c 51 | call idd_copycols(m,n,a,krank,list,col) 52 | c 53 | c 54 | c Reconstruct a, obtaining b. 55 | c 56 | call idd_reconid(m,krank,col,n,list,proj,b) 57 | c 58 | c 59 | c Compute the difference between a and b. 60 | c 61 | call materr(m,n,a,b,errmax,errrms) 62 | call prin2('errmax = *',errmax,1) 63 | call prin2('errrms = *',errrms,1) 64 | c 65 | c 66 | stop 67 | end 68 | c 69 | c 70 | c 71 | c 72 | subroutine fill(krank,m,n,a) 73 | c 74 | c fills an m x n matrix with suitably decaying singular values, 75 | c and left and right singular vectors taken from the DCT-IV. 76 | c 77 | c input: 78 | c krank -- rank of the matrix to be constructed 79 | c m -- first dimension of a 80 | c n -- second dimension of a 81 | c 82 | c output: 83 | c a -- filled matrix 84 | c 85 | implicit none 86 | integer krank,j,k,l,m,n 87 | real*8 r1,pi,a(m,n),sum 88 | c 89 | r1 = 1 90 | pi = 4*atan(r1) 91 | c 92 | c 93 | do k = 1,n 94 | do j = 1,m 95 | c 96 | sum = 0 97 | c 98 | do l = 1,krank 99 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 100 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n) 101 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 102 | enddo ! l 103 | c 104 | a(j,k) = sum 105 | c 106 | enddo ! j 107 | enddo ! k 108 | c 109 | c 110 | return 111 | end 112 | c 113 | c 114 | c 115 | c 116 | subroutine materr(m,n,a,b,errmax,errrms) 117 | c 118 | c calculates the relative maximum and root-mean-square errors 119 | c corresponding to how much a and b differ. 120 | c 121 | c input: 122 | c m -- first dimension of a and b 123 | c n -- second dimension of a and b 124 | c a -- matrix whose difference from b will be measured 125 | c b -- matrix whose difference from a will be measured 126 | c 127 | c output: 128 | c errmax -- ratio of the maximum elementwise absolute difference 129 | c between a and b to the maximum magnitude 130 | c of all the elements of a 131 | c errrms -- ratio of the root-mean-square of the elements 132 | c of the difference of a and b to the root-mean-square 133 | c of all the elements of a 134 | c 135 | implicit none 136 | integer m,n,j,k 137 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 138 | c 139 | c 140 | c Calculate the maximum magnitude amax of the elements of a 141 | c and the root-sum-square arss of the elements of a. 142 | c 143 | amax = 0 144 | arss = 0 145 | c 146 | do k = 1,n 147 | do j = 1,m 148 | c 149 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 150 | arss = arss+a(j,k)**2 151 | c 152 | enddo ! j 153 | enddo ! k 154 | c 155 | arss = sqrt(arss) 156 | c 157 | c 158 | c Calculate the maximum elementwise absolute difference 159 | c between a and b, as well as the root-sum-square errrms 160 | c of the elements of the difference of a and b. 161 | c 162 | errmax = 0 163 | errrms = 0 164 | c 165 | do k = 1,n 166 | do j = 1,m 167 | c 168 | diff = abs(a(j,k)-b(j,k)) 169 | c 170 | if(diff .gt. errmax) errmax = diff 171 | errrms = errrms+diff**2 172 | c 173 | enddo ! j 174 | enddo ! k 175 | c 176 | errrms = sqrt(errrms) 177 | c 178 | c 179 | c Calculate relative errors. 180 | c 181 | errmax = errmax/amax 182 | errrms = errrms/arss 183 | c 184 | c 185 | return 186 | end 187 | c 188 | c 189 | c 190 | c 191 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 192 | c 193 | c 194 | c The above code is for testing and debugging; the remainder of 195 | c this file contains the following user-callable routines: 196 | -------------------------------------------------------------------------------- /external/id_dist/test/iddp_asvd_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv, idd_id, id_rand, 4 | c idd_sfft, id_rtrans, idd_frm, iddp_aid, 5 | c idd_id2svd, dfft, lapack.a, blas.a 6 | c 7 | c 8 | implicit none 9 | c 10 | integer len 11 | parameter(len = 1 000 000) 12 | c 13 | integer m,n,krank,n2,ier,lw,iu,iv,is,k 14 | real*8 a(len),b(len),work(len),eps,w(len), 15 | 1 errmax,errrms,u(len),v(len),s(100 000) 16 | c 17 | c 18 | call prini(6,13) 19 | c 20 | c 21 | print *,'Enter m:' 22 | read *,m 23 | call prinf('m = *',m,1) 24 | c 25 | print *,'Enter n:' 26 | read *,n 27 | call prinf('n = *',n,1) 28 | c 29 | krank = 5 30 | call prinf('krank = *',krank,1) 31 | c 32 | c 33 | c Fill a. 34 | c 35 | call fill(krank,m,n,a,s) 36 | call prin2('a = *',a,m*n) 37 | call prin2('s = *',s,krank+1) 38 | c 39 | c 40 | c Initialize w for routine iddp_asvd. 41 | c 42 | call idd_frmi(m,n2,work) 43 | c 44 | c 45 | c Calculate an SVD approximating a. 46 | c 47 | eps = .1d-11 48 | lw = len 49 | c 50 | call iddp_asvd(lw,eps,m,n,a,work,krank,iu,iv,is,w,ier) 51 | c 52 | call prinf('ier = *',ier,1) 53 | c 54 | c 55 | c Copy u, v, and s from w. 56 | c 57 | do k = 1,krank*m 58 | u(k) = w(iu+k-1) 59 | enddo ! k 60 | c 61 | do k = 1,krank*n 62 | v(k) = w(iv+k-1) 63 | enddo ! k 64 | c 65 | do k = 1,krank 66 | s(k) = w(is+k-1) 67 | enddo ! k 68 | c 69 | c 70 | c Construct b = u diag(s) v^T. 71 | c 72 | call reconsvd(m,krank,u,s,n,v,b) 73 | call prinf('m = *',m,1) 74 | call prinf('n = *',n,1) 75 | c 76 | c 77 | c Compute the difference between a and b. 78 | c 79 | call materr(m,n,a,b,errmax,errrms) 80 | call prin2('errmax = *',errmax,1) 81 | call prin2('errrms = *',errrms,1) 82 | c 83 | c 84 | stop 85 | end 86 | c 87 | c 88 | c 89 | c 90 | subroutine fill(krank,m,n,a,s) 91 | c 92 | c fills an m x n matrix with suitably decaying singular values, 93 | c and left and right singular vectors taken from the DCT-IV. 94 | c 95 | c input: 96 | c krank -- one less than the rank of the matrix to be constructed 97 | c m -- first dimension of a 98 | c n -- second dimension of a 99 | c 100 | c output: 101 | c a -- filled matrix 102 | c s -- singular values of a 103 | c 104 | implicit none 105 | integer krank,j,k,l,m,n 106 | real*8 r1,pi,a(m,n),sum,s(krank+1) 107 | c 108 | r1 = 1 109 | pi = 4*atan(r1) 110 | c 111 | c 112 | c Specify the singular values. 113 | c 114 | do k = 1,krank 115 | s(k) = exp(log(1d-10)*(k-1)/(krank-1)) 116 | enddo ! k 117 | c 118 | s(krank+1) = 1d-10 119 | c 120 | c 121 | c Construct a. 122 | c 123 | do k = 1,n 124 | do j = 1,m 125 | c 126 | sum = 0 127 | c 128 | do l = 1,krank 129 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 130 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*s(l) 131 | enddo ! l 132 | c 133 | l = krank+1 134 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 135 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*s(l) 136 | c 137 | a(j,k) = sum 138 | c 139 | enddo ! j 140 | enddo ! k 141 | c 142 | c 143 | return 144 | end 145 | c 146 | c 147 | c 148 | c 149 | subroutine materr(m,n,a,b,errmax,errrms) 150 | c 151 | c calculates the relative maximum and root-mean-square errors 152 | c corresponding to how much a and b differ. 153 | c 154 | c input: 155 | c m -- first dimension of a and b 156 | c n -- second dimension of a and b 157 | c a -- matrix whose difference from b will be measured 158 | c b -- matrix whose difference from a will be measured 159 | c 160 | c output: 161 | c errmax -- ratio of the maximum elementwise absolute difference 162 | c between a and b to the maximum magnitude 163 | c of all the elements of a 164 | c errrms -- ratio of the root-mean-square of the elements 165 | c of the difference of a and b to the root-mean-square 166 | c of all the elements of a 167 | c 168 | implicit none 169 | integer m,n,j,k 170 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 171 | c 172 | c 173 | c Calculate the maximum magnitude amax of the elements of a 174 | c and the root-sum-square arss of the elements of a. 175 | c 176 | amax = 0 177 | arss = 0 178 | c 179 | do k = 1,n 180 | do j = 1,m 181 | c 182 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 183 | arss = arss+a(j,k)**2 184 | c 185 | enddo ! j 186 | enddo ! k 187 | c 188 | arss = sqrt(arss) 189 | c 190 | c 191 | c Calculate the maximum elementwise absolute difference 192 | c between a and b, as well as the root-sum-square errrms 193 | c of the elements of the difference of a and b. 194 | c 195 | errmax = 0 196 | errrms = 0 197 | c 198 | do k = 1,n 199 | do j = 1,m 200 | c 201 | diff = abs(a(j,k)-b(j,k)) 202 | c 203 | if(diff .gt. errmax) errmax = diff 204 | errrms = errrms+diff**2 205 | c 206 | enddo ! j 207 | enddo ! k 208 | c 209 | errrms = sqrt(errrms) 210 | c 211 | c 212 | c Calculate relative errors. 213 | c 214 | errmax = errmax/amax 215 | errrms = errrms/arss 216 | c 217 | c 218 | return 219 | end 220 | c 221 | c 222 | c 223 | c 224 | subroutine reconsvd(m,krank,u,s,n,v,a) 225 | c 226 | c forms a = u diag(s) v^T. 227 | c 228 | c input: 229 | c m -- first dimension of u and a 230 | c krank -- size of s, and second dimension of u and v 231 | c u -- leftmost matrix in the product a = u diag(s) v^T 232 | c s -- entries on the diagonal in the middle matrix 233 | c in the product a = u diag(s) v^T 234 | c n -- second dimension of a and first dimension of v 235 | c v -- rightmost matrix in the product a = u diag(s) v^T 236 | c 237 | c output: 238 | c a -- matrix product u diag(s) v^T 239 | c 240 | implicit none 241 | integer m,n,krank,j,k,l 242 | real*8 u(m,krank),s(krank),v(n,krank),a(m,n),sum 243 | c 244 | c 245 | do k = 1,n 246 | do j = 1,m 247 | c 248 | sum = 0 249 | c 250 | do l = 1,krank 251 | sum = sum+u(j,l)*s(l)*v(k,l) 252 | enddo ! l 253 | c 254 | a(j,k) = sum 255 | c 256 | enddo ! j 257 | enddo ! k 258 | c 259 | c 260 | return 261 | end 262 | c 263 | c 264 | c 265 | c 266 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 267 | c 268 | c 269 | c The above code is for testing and debugging; the remainder of 270 | c this file contains the following user-callable routines: 271 | -------------------------------------------------------------------------------- /external/id_dist/test/iddp_rid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv, idd_id, id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,krank,list(len),ier,lproj 12 | real*8 a(len),p2,p3,p4,eps,col(len), 13 | 1 errmax,errrms,proj(len),b(len) 14 | external matvect 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | c 36 | c 37 | c ID a via a randomized algorithm. 38 | c 39 | eps = .1d-12 40 | lproj = len 41 | c 42 | call iddp_rid(lproj,eps,m,n,matvect,a,p2,p3,p4, 43 | 1 krank,list,proj,ier) 44 | c 45 | call prinf('ier = *',ier,1) 46 | call prinf('list = *',list,krank) 47 | c 48 | c 49 | c Collect together the columns of a indexed by list into col. 50 | c 51 | call idd_copycols(m,n,a,krank,list,col) 52 | c 53 | c 54 | c Reconstruct a, obtaining b. 55 | c 56 | call idd_reconid(m,krank,col,n,list,proj,b) 57 | c 58 | c 59 | c Compute the difference between a and b. 60 | c 61 | call materr(m,n,a,b,errmax,errrms) 62 | call prin2('errmax = *',errmax,1) 63 | call prin2('errrms = *',errrms,1) 64 | c 65 | c 66 | stop 67 | end 68 | c 69 | c 70 | c 71 | c 72 | subroutine fill(krank,m,n,a) 73 | c 74 | c fills an m x n matrix with suitably decaying singular values, 75 | c and left and right singular vectors taken from the DCT-IV. 76 | c 77 | c input: 78 | c krank -- rank of the matrix to be constructed 79 | c m -- first dimension of a 80 | c n -- second dimension of a 81 | c 82 | c output: 83 | c a -- filled matrix 84 | c 85 | implicit none 86 | integer krank,j,k,l,m,n 87 | real*8 r1,pi,a(m,n),sum 88 | c 89 | r1 = 1 90 | pi = 4*atan(r1) 91 | c 92 | c 93 | do k = 1,n 94 | do j = 1,m 95 | c 96 | sum = 0 97 | c 98 | do l = 1,krank 99 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 100 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n) 101 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 102 | enddo ! l 103 | c 104 | a(j,k) = sum 105 | c 106 | enddo ! j 107 | enddo ! k 108 | c 109 | c 110 | return 111 | end 112 | c 113 | c 114 | c 115 | c 116 | subroutine materr(m,n,a,b,errmax,errrms) 117 | c 118 | c calculates the relative maximum and root-mean-square errors 119 | c corresponding to how much a and b differ. 120 | c 121 | c input: 122 | c m -- first dimension of a and b 123 | c n -- second dimension of a and b 124 | c a -- matrix whose difference from b will be measured 125 | c b -- matrix whose difference from a will be measured 126 | c 127 | c output: 128 | c errmax -- ratio of the maximum elementwise absolute difference 129 | c between a and b to the maximum magnitude 130 | c of all the elements of a 131 | c errrms -- ratio of the root-mean-square of the elements 132 | c of the difference of a and b to the root-mean-square 133 | c of all the elements of a 134 | c 135 | implicit none 136 | integer m,n,j,k 137 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 138 | c 139 | c 140 | c Calculate the maximum magnitude amax of the elements of a 141 | c and the root-sum-square arss of the elements of a. 142 | c 143 | amax = 0 144 | arss = 0 145 | c 146 | do k = 1,n 147 | do j = 1,m 148 | c 149 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 150 | arss = arss+a(j,k)**2 151 | c 152 | enddo ! j 153 | enddo ! k 154 | c 155 | arss = sqrt(arss) 156 | c 157 | c 158 | c Calculate the maximum elementwise absolute difference 159 | c between a and b, as well as the root-sum-square errrms 160 | c of the elements of the difference of a and b. 161 | c 162 | errmax = 0 163 | errrms = 0 164 | c 165 | do k = 1,n 166 | do j = 1,m 167 | c 168 | diff = abs(a(j,k)-b(j,k)) 169 | c 170 | if(diff .gt. errmax) errmax = diff 171 | errrms = errrms+diff**2 172 | c 173 | enddo ! j 174 | enddo ! k 175 | c 176 | errrms = sqrt(errrms) 177 | c 178 | c 179 | c Calculate relative errors. 180 | c 181 | errmax = errmax/amax 182 | errrms = errrms/arss 183 | c 184 | c 185 | return 186 | end 187 | c 188 | c 189 | c 190 | c 191 | subroutine matvect(m,x,n,y,a,p2,p3,p4) 192 | c 193 | c applies the transpose of a to x, obtaining y. 194 | c 195 | c input: 196 | c m -- first dimension of a, and length of x 197 | c x -- vector to which a^T is to be applied 198 | c n -- second dimension of a, and length of y 199 | c a -- matrix whose transpose is to be applied to x 200 | c in order to create y 201 | c p2 -- dummy input 202 | c p3 -- dummy input 203 | c p4 -- dummy input 204 | c 205 | c output: 206 | c y -- product of a^T and x 207 | c 208 | implicit none 209 | integer m,n,j,k 210 | real*8 a(m,n),p2,p3,p4,x(m),y(n),sum 211 | c 212 | c 213 | do k = 1,n 214 | c 215 | sum = 0 216 | c 217 | do j = 1,m 218 | sum = sum+a(j,k)*x(j) 219 | enddo ! j 220 | c 221 | y(k) = sum 222 | c 223 | enddo ! k 224 | c 225 | c 226 | return 227 | end 228 | c 229 | c 230 | c 231 | c 232 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 233 | c 234 | c 235 | c The above code is for testing and debugging; the remainder of 236 | c this file contains the following user-callable routines: 237 | -------------------------------------------------------------------------------- /external/id_dist/test/iddr_aid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv, idd_id, id_rand, 4 | c idd_sfft, id_rtrans, idd_frm, dfft 5 | c 6 | c 7 | implicit none 8 | c 9 | integer len 10 | parameter(len = 1 000 000) 11 | c 12 | integer m,n,krank,list(len) 13 | real*8 a(len),b(len),proj(len),col(len),errmax,errrms 14 | c 15 | c 16 | call prini(6,13) 17 | c 18 | c 19 | print *,'Enter m:' 20 | read *,m 21 | call prinf('m = *',m,1) 22 | c 23 | print *,'Enter n:' 24 | read *,n 25 | call prinf('n = *',n,1) 26 | c 27 | krank = 5 28 | call prinf('krank = *',krank,1) 29 | c 30 | c 31 | c Fill a. 32 | c 33 | call fill(krank,m,n,a) 34 | call prin2('a = *',a,m*n) 35 | c 36 | c 37 | c Initialize b as the work array for iddr_aid. 38 | c 39 | call iddr_aidi(m,n,krank,b) 40 | c 41 | c 42 | c ID a. 43 | c 44 | call iddr_aid(m,n,a,krank,b,list,proj) 45 | call prinf('list = *',list,krank) 46 | c 47 | c 48 | c Collect together the columns of a indexed by list into col. 49 | c 50 | call idd_copycols(m,n,a,krank,list,col) 51 | c 52 | c 53 | c Reconstruct a, obtaining b. 54 | c 55 | call idd_reconid(m,krank,col,n,list,proj,b) 56 | c 57 | c 58 | c Compute the difference between a and b. 59 | c 60 | call materr(m,n,a,b,errmax,errrms) 61 | call prin2('errmax = *',errmax,1) 62 | call prin2('errrms = *',errrms,1) 63 | c 64 | c 65 | stop 66 | end 67 | c 68 | c 69 | c 70 | c 71 | subroutine fill(krank,m,n,a) 72 | c 73 | c fills an m x n matrix with suitably decaying singular values, 74 | c and left and right singular vectors taken from the DCT-IV. 75 | c 76 | c input: 77 | c krank -- one less than the rank of the matrix to be constructed 78 | c m -- first dimension of a 79 | c n -- second dimension of a 80 | c 81 | c output: 82 | c a -- filled matrix 83 | c 84 | implicit none 85 | integer krank,j,k,l,m,n 86 | real*8 r1,pi,a(m,n),sum 87 | c 88 | r1 = 1 89 | pi = 4*atan(r1) 90 | c 91 | c 92 | do k = 1,n 93 | do j = 1,m 94 | c 95 | sum = 0 96 | c 97 | do l = 1,krank 98 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 99 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n) 100 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 101 | enddo ! l 102 | c 103 | l = krank+1 104 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 105 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*1d-10 106 | c 107 | a(j,k) = sum 108 | c 109 | enddo ! j 110 | enddo ! k 111 | c 112 | c 113 | return 114 | end 115 | c 116 | c 117 | c 118 | c 119 | subroutine materr(m,n,a,b,errmax,errrms) 120 | c 121 | c calculates the relative maximum and root-mean-square errors 122 | c corresponding to how much a and b differ. 123 | c 124 | c input: 125 | c m -- first dimension of a and b 126 | c n -- second dimension of a and b 127 | c a -- matrix whose difference from b will be measured 128 | c b -- matrix whose difference from a will be measured 129 | c 130 | c output: 131 | c errmax -- ratio of the maximum elementwise absolute difference 132 | c between a and b to the maximum magnitude 133 | c of all the elements of a 134 | c errrms -- ratio of the root-mean-square of the elements 135 | c of the difference of a and b to the root-mean-square 136 | c of all the elements of a 137 | c 138 | implicit none 139 | integer m,n,j,k 140 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 141 | c 142 | c 143 | c Calculate the maximum magnitude amax of the elements of a 144 | c and the root-sum-square arss of the elements of a. 145 | c 146 | amax = 0 147 | arss = 0 148 | c 149 | do k = 1,n 150 | do j = 1,m 151 | c 152 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 153 | arss = arss+a(j,k)**2 154 | c 155 | enddo ! j 156 | enddo ! k 157 | c 158 | arss = sqrt(arss) 159 | c 160 | c 161 | c Calculate the maximum elementwise absolute difference 162 | c between a and b, as well as the root-sum-square errrms 163 | c of the elements of the difference of a and b. 164 | c 165 | errmax = 0 166 | errrms = 0 167 | c 168 | do k = 1,n 169 | do j = 1,m 170 | c 171 | diff = abs(a(j,k)-b(j,k)) 172 | c 173 | if(diff .gt. errmax) errmax = diff 174 | errrms = errrms+diff**2 175 | c 176 | enddo ! j 177 | enddo ! k 178 | c 179 | errrms = sqrt(errrms) 180 | c 181 | c 182 | c Calculate relative errors. 183 | c 184 | errmax = errmax/amax 185 | errrms = errrms/arss 186 | c 187 | c 188 | return 189 | end 190 | c 191 | c 192 | c 193 | c 194 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 195 | c 196 | c 197 | c The above code is for testing and debugging; the remainder of 198 | c this file contains the following user-callable routines: 199 | -------------------------------------------------------------------------------- /external/id_dist/test/iddr_asvd_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv, idd_id, id_rand, 4 | c idd_sfft, id_rtrans, idd_frm, iddr_aid, 5 | c idd_id2svd, dfft, lapack.a, blas.a 6 | c 7 | c 8 | implicit none 9 | c 10 | integer len 11 | parameter(len = 1 000 000) 12 | c 13 | integer m,n,krank,ier 14 | real*8 a(len),b(len),errmax,errrms,u(len),v(len),s(100 000), 15 | 1 w(len) 16 | c 17 | c 18 | call prini(6,13) 19 | c 20 | c 21 | print *,'Enter m:' 22 | read *,m 23 | call prinf('m = *',m,1) 24 | c 25 | print *,'Enter n:' 26 | read *,n 27 | call prinf('n = *',n,1) 28 | c 29 | krank = 5 30 | call prinf('krank = *',krank,1) 31 | c 32 | c 33 | c Fill a. 34 | c 35 | call fill(krank,m,n,a,s) 36 | call prin2('a = *',a,m*n) 37 | call prin2('s = *',s,krank+1) 38 | c 39 | c 40 | c Calculate an SVD approximating a. 41 | c 42 | call iddr_aidi(m,n,krank,w) 43 | call iddr_asvd(m,n,a,krank,w,u,v,s,ier) 44 | c 45 | c 46 | c Construct b = u diag(s) v^T. 47 | c 48 | call reconsvd(m,krank,u,s,n,v,b) 49 | c 50 | c 51 | c Compute the difference between a and b. 52 | c 53 | call materr(m,n,a,b,errmax,errrms) 54 | call prin2('errmax = *',errmax,1) 55 | call prin2('errrms = *',errrms,1) 56 | c 57 | c 58 | stop 59 | end 60 | c 61 | c 62 | c 63 | c 64 | subroutine fill(krank,m,n,a,s) 65 | c 66 | c fills an m x n matrix with suitably decaying singular values, 67 | c and left and right singular vectors taken from the DCT-IV. 68 | c 69 | c input: 70 | c krank -- one less than the rank of the matrix to be constructed 71 | c m -- first dimension of a 72 | c n -- second dimension of a 73 | c 74 | c output: 75 | c a -- filled matrix 76 | c s -- singular values of a 77 | c 78 | implicit none 79 | integer krank,j,k,l,m,n 80 | real*8 r1,pi,a(m,n),sum,s(krank+1) 81 | c 82 | r1 = 1 83 | pi = 4*atan(r1) 84 | c 85 | c 86 | c Specify the singular values. 87 | c 88 | do k = 1,krank 89 | s(k) = exp(log(1d-10)*(k-1)/(krank-1)) 90 | enddo ! k 91 | c 92 | s(krank+1) = 1d-10 93 | c 94 | c 95 | c Construct a. 96 | c 97 | do k = 1,n 98 | do j = 1,m 99 | c 100 | sum = 0 101 | c 102 | do l = 1,krank 103 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 104 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*s(l) 105 | enddo ! l 106 | c 107 | l = krank+1 108 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 109 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*s(l) 110 | c 111 | a(j,k) = sum 112 | c 113 | enddo ! j 114 | enddo ! k 115 | c 116 | c 117 | return 118 | end 119 | c 120 | c 121 | c 122 | c 123 | subroutine materr(m,n,a,b,errmax,errrms) 124 | c 125 | c calculates the relative maximum and root-mean-square errors 126 | c corresponding to how much a and b differ. 127 | c 128 | c input: 129 | c m -- first dimension of a and b 130 | c n -- second dimension of a and b 131 | c a -- matrix whose difference from b will be measured 132 | c b -- matrix whose difference from a will be measured 133 | c 134 | c output: 135 | c errmax -- ratio of the maximum elementwise absolute difference 136 | c between a and b to the maximum magnitude 137 | c of all the elements of a 138 | c errrms -- ratio of the root-mean-square of the elements 139 | c of the difference of a and b to the root-mean-square 140 | c of all the elements of a 141 | c 142 | implicit none 143 | integer m,n,j,k 144 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 145 | c 146 | c 147 | c Calculate the maximum magnitude amax of the elements of a 148 | c and the root-sum-square arss of the elements of a. 149 | c 150 | amax = 0 151 | arss = 0 152 | c 153 | do k = 1,n 154 | do j = 1,m 155 | c 156 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 157 | arss = arss+a(j,k)**2 158 | c 159 | enddo ! j 160 | enddo ! k 161 | c 162 | arss = sqrt(arss) 163 | c 164 | c 165 | c Calculate the maximum elementwise absolute difference 166 | c between a and b, as well as the root-sum-square errrms 167 | c of the elements of the difference of a and b. 168 | c 169 | errmax = 0 170 | errrms = 0 171 | c 172 | do k = 1,n 173 | do j = 1,m 174 | c 175 | diff = abs(a(j,k)-b(j,k)) 176 | c 177 | if(diff .gt. errmax) errmax = diff 178 | errrms = errrms+diff**2 179 | c 180 | enddo ! j 181 | enddo ! k 182 | c 183 | errrms = sqrt(errrms) 184 | c 185 | c 186 | c Calculate relative errors. 187 | c 188 | errmax = errmax/amax 189 | errrms = errrms/arss 190 | c 191 | c 192 | return 193 | end 194 | c 195 | c 196 | c 197 | c 198 | subroutine reconsvd(m,krank,u,s,n,v,a) 199 | c 200 | c forms a = u diag(s) v^T. 201 | c 202 | c input: 203 | c m -- first dimension of u and a 204 | c krank -- size of s, and second dimension of u and v 205 | c u -- leftmost matrix in the product a = u diag(s) v^T 206 | c s -- entries on the diagonal in the middle matrix 207 | c in the product a = u diag(s) v^T 208 | c n -- second dimension of a and first dimension of v 209 | c v -- rightmost matrix in the product a = u diag(s) v^T 210 | c 211 | c output: 212 | c a -- matrix product u diag(s) v^T 213 | c 214 | implicit none 215 | integer m,n,krank,j,k,l 216 | real*8 u(m,krank),s(krank),v(n,krank),a(m,n),sum 217 | c 218 | c 219 | do k = 1,n 220 | do j = 1,m 221 | c 222 | sum = 0 223 | c 224 | do l = 1,krank 225 | sum = sum+u(j,l)*s(l)*v(k,l) 226 | enddo ! l 227 | c 228 | a(j,k) = sum 229 | c 230 | enddo ! j 231 | enddo ! k 232 | c 233 | c 234 | return 235 | end 236 | c 237 | c 238 | c 239 | c 240 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 241 | c 242 | c 243 | c The above code is for testing and debugging; the remainder of 244 | c this file contains the following user-callable routines: 245 | -------------------------------------------------------------------------------- /external/id_dist/test/iddr_rid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idd_house, idd_qrpiv, idd_id, id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,krank,list(len) 12 | real*8 a(len),p2,p3,p4,b(len),proj(len), 13 | 1 col(len),errmax,errrms 14 | external matvect 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | call prin2('a = *',a,m*n) 36 | c 37 | c 38 | c ID a. 39 | c 40 | call iddr_rid(m,n,matvect,a,p2,p3,p4,krank,list,proj) 41 | call prinf('list = *',list,krank) 42 | c 43 | c 44 | c Collect together the columns of a indexed by list into col. 45 | c 46 | call idd_copycols(m,n,a,krank,list,col) 47 | c 48 | c 49 | c Reconstruct a, obtaining b. 50 | c 51 | call idd_reconid(m,krank,col,n,list,proj,b) 52 | c 53 | c 54 | c Compute the difference between a and b. 55 | c 56 | call materr(m,n,a,b,errmax,errrms) 57 | call prin2('errmax = *',errmax,1) 58 | call prin2('errrms = *',errrms,1) 59 | c 60 | c 61 | stop 62 | end 63 | c 64 | c 65 | c 66 | c 67 | subroutine fill(krank,m,n,a) 68 | c 69 | c fills an m x n matrix with suitably decaying singular values, 70 | c and left and right singular vectors taken from the DCT-IV. 71 | c 72 | c input: 73 | c krank -- one less than the rank of the matrix to be constructed 74 | c m -- first dimension of a 75 | c n -- second dimension of a 76 | c 77 | c output: 78 | c a -- filled matrix 79 | c 80 | implicit none 81 | integer krank,j,k,l,m,n 82 | real*8 r1,pi,a(m,n),sum 83 | c 84 | r1 = 1 85 | pi = 4*atan(r1) 86 | c 87 | c 88 | do k = 1,n 89 | do j = 1,m 90 | c 91 | sum = 0 92 | c 93 | do l = 1,krank 94 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 95 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n) 96 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 97 | enddo ! l 98 | c 99 | l = krank+1 100 | sum = sum+cos(pi*(j-r1/2)*(l-r1/2)/m)*sqrt(r1*2/m) 101 | 1 *cos(pi*(k-r1/2)*(l-r1/2)/n)*sqrt(r1*2/n)*1d-10 102 | c 103 | a(j,k) = sum 104 | c 105 | enddo ! j 106 | enddo ! k 107 | c 108 | c 109 | return 110 | end 111 | c 112 | c 113 | c 114 | c 115 | subroutine materr(m,n,a,b,errmax,errrms) 116 | c 117 | c calculates the relative maximum and root-mean-square errors 118 | c corresponding to how much a and b differ. 119 | c 120 | c input: 121 | c m -- first dimension of a and b 122 | c n -- second dimension of a and b 123 | c a -- matrix whose difference from b will be measured 124 | c b -- matrix whose difference from a will be measured 125 | c 126 | c output: 127 | c errmax -- ratio of the maximum elementwise absolute difference 128 | c between a and b to the maximum magnitude 129 | c of all the elements of a 130 | c errrms -- ratio of the root-mean-square of the elements 131 | c of the difference of a and b to the root-mean-square 132 | c of all the elements of a 133 | c 134 | implicit none 135 | integer m,n,j,k 136 | real*8 a(m,n),b(m,n),errmax,errrms,diff,amax,arss 137 | c 138 | c 139 | c Calculate the maximum magnitude amax of the elements of a 140 | c and the root-sum-square arss of the elements of a. 141 | c 142 | amax = 0 143 | arss = 0 144 | c 145 | do k = 1,n 146 | do j = 1,m 147 | c 148 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 149 | arss = arss+a(j,k)**2 150 | c 151 | enddo ! j 152 | enddo ! k 153 | c 154 | arss = sqrt(arss) 155 | c 156 | c 157 | c Calculate the maximum elementwise absolute difference 158 | c between a and b, as well as the root-sum-square errrms 159 | c of the elements of the difference of a and b. 160 | c 161 | errmax = 0 162 | errrms = 0 163 | c 164 | do k = 1,n 165 | do j = 1,m 166 | c 167 | diff = abs(a(j,k)-b(j,k)) 168 | c 169 | if(diff .gt. errmax) errmax = diff 170 | errrms = errrms+diff**2 171 | c 172 | enddo ! j 173 | enddo ! k 174 | c 175 | errrms = sqrt(errrms) 176 | c 177 | c 178 | c Calculate relative errors. 179 | c 180 | errmax = errmax/amax 181 | errrms = errrms/arss 182 | c 183 | c 184 | return 185 | end 186 | c 187 | c 188 | c 189 | c 190 | subroutine matvect(m,x,n,y,a,p2,p3,p4) 191 | c 192 | c applies the transpose of a to x, obtaining y. 193 | c 194 | c input: 195 | c m -- first dimension of a, and length of x 196 | c x -- vector to which a^T is to be applied 197 | c n -- second dimension of a, and length of y 198 | c a -- matrix whose transpose is to be applied to x 199 | c in order to create y 200 | c p2 -- dummy input 201 | c p3 -- dummy input 202 | c p4 -- dummy input 203 | c 204 | c output: 205 | c y -- product of a^T and x 206 | c 207 | implicit none 208 | integer m,n,j,k 209 | real*8 a(m,n),p2,p3,p4,x(m),y(n),sum 210 | c 211 | c 212 | do k = 1,n 213 | c 214 | sum = 0 215 | c 216 | do j = 1,m 217 | sum = sum+a(j,k)*x(j) 218 | enddo ! j 219 | c 220 | y(k) = sum 221 | c 222 | enddo ! k 223 | c 224 | c 225 | return 226 | end 227 | c 228 | c 229 | c 230 | c 231 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 232 | c 233 | c 234 | c The above code is for testing and debugging; the remainder of 235 | c this file contains the following user-callable routines: 236 | -------------------------------------------------------------------------------- /external/id_dist/test/idz_house_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer n,k,ifrescal 12 | real*8 scal,diffmax,difffrob,diff1,diffmax2ton,r1,rss 13 | complex*16 x(len),vn(len),h(len),c(len),y(len), 14 | 1 hadjoint(len),ci,csshh 15 | c 16 | r1 = 1 17 | ci = (0,1) 18 | c 19 | c 20 | call prini(6,13) 21 | c 22 | c 23 | print *,'Enter n (the length of the vector to reflect ' 24 | 1 //'into its first component): ' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | c 29 | c Fill x with something. 30 | c 31 | do k = 1,n 32 | x(k) = sqrt(r1*k)-ci*k 33 | enddo ! k 34 | call prin2('x = *',x,2*n) 35 | c 36 | c 37 | c Calculate the normalized Householder vector vn 38 | c corresponding to x. 39 | c 40 | call idz_house(n,x,csshh,vn,scal) 41 | call prin2('csshh = *',csshh,2) 42 | c 43 | c 44 | c Build the Householder transformation matrix h from vn. 45 | c 46 | call idz_housemat(n,vn,scal,h) 47 | c 48 | c 49 | c Calculate the root-sum-square of the entries of x. 50 | c 51 | call ccalcrss(n,x,rss) 52 | call prin2('rss = *',rss,1) 53 | c 54 | c 55 | c Apply the Householder matrix for vector vn and scalar scal 56 | c to x, yielding y. 57 | c 58 | ifrescal = 1 59 | call idz_houseapp(n,vn,x,ifrescal,scal,y) 60 | call prin2('y = *',y,2*n) 61 | c 62 | c 63 | c Check that abs(y(1)) = rss. 64 | c 65 | diff1 = abs( rss-abs(y(1)) ) 66 | diff1 = diff1/rss 67 | call prin2('diff1 = *',diff1,1) 68 | c 69 | c 70 | c Check that y(2) = 0, ..., y(n) = 0. 71 | c 72 | diffmax2ton = 0 73 | c 74 | do k = 2,n 75 | if(abs(y(k)) .gt. diffmax2ton) diffmax2ton = abs(y(k)) 76 | enddo ! k 77 | c 78 | diffmax2ton = diffmax2ton/rss 79 | call prin2('diffmax2ton = *',diffmax2ton,1) 80 | c 81 | c 82 | c Check that h adjoint(h) = _1_ 83 | c (h adjoint(h) = _1_ because h is both symmetric and unitary). 84 | c 85 | call cmatadjoint(n,h,hadjoint) 86 | call cmultiply(n,h,hadjoint,c) 87 | call ccheckid(n,c,diffmax,difffrob) 88 | call prin2('diffmax = *',diffmax,1) 89 | call prin2('difffrob = *',difffrob,1) 90 | c 91 | c 92 | stop 93 | end 94 | c 95 | c 96 | c 97 | c 98 | subroutine cmatadjoint(n,h,hadjoint) 99 | c 100 | c forms the adjoint hadjoint of h. 101 | c 102 | c input: 103 | c n -- first and second dimensions of h and hadjoint 104 | c h -- matrix for which the adjoint is taken 105 | c 106 | c output: 107 | c hadjoint -- adjoint of h 108 | c 109 | implicit none 110 | integer n,j,k 111 | complex*16 h(n,n),hadjoint(n,n) 112 | c 113 | c 114 | do k = 1,n 115 | do j = 1,n 116 | hadjoint(j,k) = conjg(h(k,j)) 117 | enddo ! j 118 | enddo ! k 119 | c 120 | c 121 | return 122 | end 123 | c 124 | c 125 | c 126 | c 127 | subroutine cmultiply(n,a,b,c) 128 | c 129 | c multiplies a and b to get c. 130 | c 131 | c input: 132 | c n -- size of a, b, and c 133 | c a -- n x n matrix to be applied to b 134 | c b -- n x n matrix to which a is applied 135 | c 136 | c output: 137 | c c -- matrix resulting from applying a to b 138 | c 139 | implicit none 140 | integer n,j,k,l 141 | complex*16 a(n,n),b(n,n),c(n,n) 142 | c 143 | c 144 | do j = 1,n 145 | do l = 1,n 146 | c(j,l) = 0 147 | enddo ! l 148 | enddo ! j 149 | c 150 | do l = 1,n 151 | do j = 1,n 152 | c 153 | do k = 1,n 154 | c(j,l) = c(j,l)+a(k,j)*b(l,k) 155 | enddo ! k 156 | c 157 | enddo ! j 158 | enddo ! l 159 | c 160 | c 161 | return 162 | end 163 | c 164 | c 165 | c 166 | c 167 | subroutine ccheckid(n,c,diffmax,difffrob) 168 | c 169 | c calculates the difference between c and the identity matrix. 170 | c 171 | c input: 172 | c n -- size of c 173 | c c -- matrix that is supposed to be close to the identity 174 | c 175 | c output: 176 | c diffmax -- maximum entrywise difference 177 | c between c and the identity 178 | c difffrob -- root-sum-square of the entries 179 | c of the matrix identity_matrix - c 180 | c 181 | implicit none 182 | integer n,j,k 183 | real*8 diffmax,difffrob,diff 184 | complex*16 c(n,n) 185 | c 186 | c 187 | diffmax = 0 188 | difffrob = 0 189 | c 190 | do j = 1,n 191 | do k = 1,n 192 | c 193 | if(k .eq. j) diff = abs(1-c(k,j)) 194 | if(k .ne. j) diff = abs(c(k,j)) 195 | c 196 | if(diff .gt. diffmax) diffmax = diff 197 | difffrob = difffrob+diff**2 198 | c 199 | enddo ! k 200 | enddo ! j 201 | c 202 | difffrob = sqrt(difffrob) 203 | c 204 | c 205 | return 206 | end 207 | c 208 | c 209 | c 210 | c 211 | subroutine disp(n,a) 212 | c 213 | c displays the n x n matrix a. 214 | c 215 | c input: 216 | c n -- size of a 217 | c a -- n x n matrix to be written to the output stream 218 | c 219 | implicit none 220 | integer n,k 221 | real*8 a(n,n) 222 | c 223 | c 224 | do k = 1,n 225 | call prin2('*',a(1,k),n) 226 | enddo ! j 227 | c 228 | c 229 | return 230 | end 231 | c 232 | c 233 | c 234 | c 235 | subroutine ccalcrss(n,v,rss) 236 | c 237 | c calculates the root-sum-square of the entries of v. 238 | c 239 | c input: 240 | c n -- size of v 241 | c v -- vector whose entries are to be root-sum-squared 242 | c 243 | c output: 244 | c rss -- root-sum-square of the entries of v 245 | c 246 | implicit none 247 | integer n,k 248 | real*8 rss 249 | complex*16 v(n) 250 | c 251 | c 252 | rss = 0 253 | do k = 1,n 254 | rss = rss+v(k)*conjg(v(k)) 255 | enddo ! k 256 | rss = sqrt(rss) 257 | c 258 | c 259 | return 260 | end 261 | c 262 | c 263 | c 264 | c 265 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 266 | c 267 | c 268 | c The above code is for testing and debugging; the remainder of 269 | c this file contains the following user-callable routines: 270 | -------------------------------------------------------------------------------- /external/id_dist/test/idz_id_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idz_house, idz_qrpiv 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,ifdisp 12 | complex*16 a(len),a0(len),col(len) 13 | c 14 | c 15 | call prini(6,13) 16 | c 17 | c 18 | print *, 19 | 1 'To display full matrices, enter 1; otherwise, enter 0:' 20 | read *,ifdisp 21 | call prinf('ifdisp = *',ifdisp,1) 22 | c 23 | print *,'Enter m:' 24 | read *,m 25 | call prinf('m = *',m,1) 26 | c 27 | print *,'Enter n:' 28 | read *,n 29 | call prinf('n = *',n,1) 30 | c 31 | c 32 | call ccheck(ifdisp,m,n,a,a0,col) 33 | c 34 | c 35 | stop 36 | end 37 | c 38 | c 39 | c 40 | c 41 | subroutine ccheck(ifdisp,m,n,a,a0,col) 42 | c 43 | implicit none 44 | c 45 | integer len 46 | parameter(len = 1 000 000) 47 | c 48 | integer m,n,j,k,krank,list(len),ifdisp,loop 49 | real*8 r1,pi,work(len),errmax,errrms,eps 50 | complex*16 a(m,n),a0(m,n),approx(len),col(len),ci 51 | c 52 | r1 = 1 53 | ci = (0,1) 54 | pi = 4*atan(r1) 55 | c 56 | c 57 | c Fill a0 with something. 58 | c 59 | do k = 1,n 60 | do j = 1,m 61 | a0(j,k) = sin(j*k/(r1*m+1)) - ci*cos(j**2*k/(r1*m+3)) 62 | enddo ! j 63 | enddo ! k 64 | c 65 | if(n .ge. 6) then 66 | c 67 | do k = 4,6 68 | do j = 1,m 69 | a0(j,k) = ( a0(j,k-3)+a0(j,1) )/5 70 | enddo ! j 71 | enddo ! k 72 | c 73 | endif 74 | c 75 | if(ifdisp .eq. 1) call rectdisp('a0 = *',a0,2*m,n) 76 | c 77 | c 78 | do loop = 1,2 79 | c 80 | c 81 | c Duplicate a0 into a. 82 | c 83 | do k = 1,n 84 | do j = 1,m 85 | a(j,k) = a0(j,k) 86 | enddo ! j 87 | enddo ! k 88 | c 89 | c 90 | if(loop .eq. 1) then 91 | c 92 | c 93 | c ID a. 94 | c 95 | eps = .1d-13 96 | c 97 | call idzp_id(eps,m,n,a,krank,list,work) 98 | c 99 | call prinf('krank = *',krank,1) 100 | call prinf('list = *',list,n) 101 | if(ifdisp .eq. 1) 102 | 1 call rectdisp('a (proj) = *',a,2*krank,n-krank) 103 | c 104 | c 105 | endif ! loop .eq. 1 106 | c 107 | c 108 | if(loop .eq. 2) then 109 | c 110 | c 111 | c ID a. 112 | c 113 | call idzr_id(m,n,a,krank,list,work) 114 | call prinf('list = *',list,n) 115 | if(ifdisp .eq. 1) 116 | 1 call rectdisp('a (proj) = *',a,2*krank,n-krank) 117 | c 118 | c 119 | endif ! loop .eq. 2 120 | c 121 | c 122 | c Copy the selected columns of a0 into col 123 | c (in the order given by list). 124 | c 125 | call idz_copycols(m,n,a0,krank,list,col) 126 | c 127 | c 128 | c Reconstruct a0 from col and the proj in a. 129 | c 130 | call idz_reconid(m,krank,col,n,list,a,approx) 131 | if(ifdisp .eq. 1) call rectdisp('approx = *',approx,2*m,n) 132 | c 133 | c 134 | if(krank .gt. 0) then 135 | c 136 | c Calculate the relative maximum and root-mean-square errors 137 | c corresponding to how much a0 and approx differ. 138 | c 139 | call cmaterr(m,n,a0,approx,errmax,errrms) 140 | call prin2('errmax = *',errmax,1) 141 | call prin2('errrms = *',errrms,1) 142 | c 143 | endif 144 | c 145 | c 146 | enddo ! loop 147 | c 148 | c 149 | return 150 | end 151 | c 152 | c 153 | c 154 | c 155 | subroutine cmaterr(m,n,a,b,errmax,errrms) 156 | c 157 | c calculates the relative maximum and root-mean-square errors 158 | c corresponding to how much a and b differ. 159 | c 160 | c input: 161 | c m -- first dimension of a and b 162 | c n -- second dimension of a and b 163 | c a -- matrix whose difference from b will be measured 164 | c b -- matrix whose difference from a will be measured 165 | c 166 | c output: 167 | c errmax -- ratio of the maximum elementwise absolute difference 168 | c between a and b to the maximum magnitude 169 | c of all the elements of a 170 | c errrms -- ratio of the root-mean-square of the elements 171 | c of the difference of a and b to the root-mean-square 172 | c of all the elements of a 173 | c 174 | implicit none 175 | integer m,n,j,k 176 | real*8 errmax,errrms,diff,amax,arss 177 | complex*16 a(m,n),b(m,n) 178 | c 179 | c 180 | c Calculate the maximum magnitude amax of the elements of a 181 | c and the root-sum-square arss of the elements of a. 182 | c 183 | amax = 0 184 | arss = 0 185 | c 186 | do k = 1,n 187 | do j = 1,m 188 | c 189 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 190 | arss = arss+a(j,k)*conjg(a(j,k)) 191 | c 192 | enddo ! j 193 | enddo ! k 194 | c 195 | arss = sqrt(arss) 196 | c 197 | c 198 | c Calculate the maximum elementwise absolute difference 199 | c between a and b, as well as the root-sum-square errrms 200 | c of the elements of the difference of a and b. 201 | c 202 | errmax = 0 203 | errrms = 0 204 | c 205 | do k = 1,n 206 | do j = 1,m 207 | c 208 | diff = abs(a(j,k)-b(j,k)) 209 | c 210 | if(diff .gt. errmax) errmax = diff 211 | errrms = errrms+diff**2 212 | c 213 | enddo ! j 214 | enddo ! k 215 | c 216 | errrms = sqrt(errrms) 217 | c 218 | c 219 | c Calculate relative errors. 220 | c 221 | errmax = errmax/amax 222 | errrms = errrms/arss 223 | c 224 | c 225 | return 226 | end 227 | c 228 | c 229 | c 230 | c 231 | subroutine rectdisp(str,a,m,n) 232 | c 233 | c displays a real rectangular matrix a via prini, 234 | c with the first index of a ascending as you read the rows 235 | c from left to right, 236 | c and the second index of a ascending as you read the columns 237 | c from top to bottom. 238 | c 239 | c input: 240 | c str -- message for prin2 241 | c a -- matrix to display 242 | c m -- first dimension of a 243 | c n -- second dimension of a 244 | c 245 | c _N.B._: You must call prini for initialization 246 | c before calling this routine. 247 | c 248 | implicit none 249 | integer m,n,k 250 | real*8 a(m,n) 251 | character*1 str(1) 252 | c 253 | c 254 | call prin2(str,a,0) 255 | do k = 1,n 256 | call prin2('*',a(1,k),m) 257 | enddo ! k 258 | c 259 | c 260 | return 261 | end 262 | c 263 | c 264 | c 265 | c 266 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 267 | c 268 | c 269 | c The above code is for testing and debugging; the remainder of 270 | c this file contains the following user-callable routines: 271 | -------------------------------------------------------------------------------- /external/id_dist/test/idz_sfft_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, dfft, and (for the debugging code) id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer n,k,l,ind(len),nblock 12 | real*8 r1,rnd,diffmax 13 | complex*16 v(len),v2(len),disp(len),disp2(len), 14 | 1 wsave(len),w(len) 15 | c 16 | r1 = 1 17 | c 18 | c 19 | call prini(6,13) 20 | c 21 | c 22 | print *,'Enter n:' 23 | read *,n 24 | call prinf('n = *',n,1) 25 | c 26 | c 27 | l = 15 28 | call prinf('l = *',l,1) 29 | c 30 | c 31 | c Choose at random locations to calculate. 32 | c 33 | do k = 1,l 34 | call id_srand(1,rnd) 35 | ind(k) = 1+n*rnd 36 | if(ind(k) .gt. n) ind(k) = n 37 | enddo ! k 38 | call prinf('ind = *',ind,l) 39 | c 40 | c 41 | c Fill the real and imaginary parts of every entry 42 | c of the vector v being transformed with i.i.d. random variates, 43 | c drawn uniformly from [0,1]. 44 | c 45 | call id_srand(2*n,v) 46 | c 47 | c 48 | c Copy v into v2. 49 | c 50 | do k = 1,n 51 | v2(k) = v(k) 52 | enddo ! k 53 | c 54 | c 55 | c Transform v2 via zfft2. 56 | c 57 | call idz_ldiv(l,n,nblock) 58 | call zfftf2(nblock,n,v2,w) 59 | c 60 | do k = 1,l 61 | disp2(k) = v2(ind(k)) 62 | enddo ! k 63 | c 64 | call prin2('disp2 = *',disp2,2*l) 65 | c 66 | c 67 | c Transform v via idz_sfft. 68 | c 69 | call idz_sffti(l,ind,n,wsave) 70 | call idz_sfft(l,ind,n,wsave,v) 71 | c 72 | do k = 1,l 73 | disp(k) = v(ind(k)) 74 | enddo ! k 75 | c 76 | call prin2('disp = *',disp,2*l) 77 | c 78 | c 79 | c Find the difference between disp and disp2. 80 | c 81 | diffmax = 0 82 | c 83 | do k = 1,l 84 | if(abs(disp(k)-disp2(k)) .gt. diffmax) 85 | 1 diffmax = abs(disp(k)-disp2(k)) 86 | enddo ! k 87 | c 88 | call prin2('diffmax = *',diffmax,1) 89 | c 90 | c 91 | stop 92 | end 93 | c 94 | c 95 | c 96 | c 97 | subroutine zfftf2(l,n,v,w) 98 | c 99 | c calculate via a full FFT what idz_sfft would compute 100 | c if it calculated every entry, rather than just a subset 101 | c of l entries. 102 | c 103 | c input: 104 | c l -- number of entries in the output to compute 105 | c n -- length of v 106 | c v -- vector to be transformed 107 | c 108 | c output: 109 | c v -- transformed vector 110 | c 111 | c work: 112 | c w -- must be at least 2*n+15 complex*16 elements long 113 | c 114 | implicit none 115 | integer n,l,k 116 | real*8 r1,fact 117 | complex*16 v(n),w(2*n+15) 118 | c 119 | r1 = 1 120 | c 121 | c 122 | c Transpose v. 123 | c 124 | call vectrans(l,n,v,w) 125 | c 126 | c 127 | c Transform v via zfftf and normalize it. 128 | c 129 | call zffti(n,w) 130 | call zfftf(n,v,w) 131 | c 132 | fact = 1/sqrt(r1*n) 133 | do k = 1,n 134 | v(k) = v(k)*fact 135 | enddo ! k 136 | c 137 | c 138 | c Transpose v. 139 | c 140 | call vectrans(l,n,v,w) 141 | c 142 | c 143 | return 144 | end 145 | c 146 | c 147 | c 148 | c 149 | subroutine vectrans(l,n,v,w) 150 | c 151 | c transposes v. 152 | c 153 | c input: 154 | c l -- first stride 155 | c n -- length of v 156 | c 157 | c output: 158 | c v -- transposed vector 159 | c 160 | c work: 161 | c w -- must be at least n complex*16 elements long 162 | c 163 | implicit none 164 | integer n,m,l,k,j 165 | complex*16 v(n),w(n) 166 | c 167 | c 168 | m = n/l 169 | c 170 | c 171 | c Transpose v to obtain w. 172 | c 173 | do k = 1,m 174 | do j = 1,l 175 | w(m*(j-1)+k) = v(l*(k-1)+j) 176 | enddo ! j 177 | enddo ! k 178 | c 179 | c 180 | c Copy w into v. 181 | c 182 | do k = 1,n 183 | v(k) = w(k) 184 | enddo ! k 185 | c 186 | c 187 | return 188 | end 189 | c 190 | c 191 | c 192 | c 193 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 194 | c 195 | c 196 | c The above code is for testing and debugging; the remainder of 197 | c this file contains the following user-callable routines: 198 | -------------------------------------------------------------------------------- /external/id_dist/test/idz_snorm_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,krank,its,k 12 | real*8 snorm,diffsnorm,r1 13 | complex*16 a(len),dummy,u(len),v(len),b(len),rnd 14 | external matvec,matveca 15 | c 16 | r1 = 1 17 | c 18 | c 19 | call prini(6,13) 20 | c 21 | c 22 | print *,'Enter m:' 23 | read *,m 24 | call prinf('m = *',m,1) 25 | c 26 | print *,'Enter n:' 27 | read *,n 28 | call prinf('n = *',n,1) 29 | c 30 | krank = 5 31 | call prinf('krank = *',krank,1) 32 | c 33 | c 34 | c Fill a with a matrix whose spectral norm is 2. 35 | c 36 | call fill(krank,m,n,a) 37 | c 38 | c 39 | c Calculate the spectral norm of a. 40 | c 41 | its = 100 42 | c 43 | call idz_snorm(m,n,matveca,a,dummy,dummy,dummy, 44 | 1 matvec,a,dummy,dummy,dummy,its,snorm,v,u) 45 | c 46 | c 47 | c Divide snorm by 2 and display it. 48 | c 49 | snorm = snorm/2 50 | call prin2('snorm (which should be 1) = *',snorm,1) 51 | c 52 | c 53 | c Add a little noise to a, obtaining b. 54 | c 55 | do k = 1,m*n 56 | call id_srand(2,rnd) 57 | b(k) = a(k)+.1d-12*(2*rnd-1) 58 | enddo ! k 59 | c 60 | c 61 | c Calculate the spectral norm of a-b. 62 | c 63 | its = 100 64 | c 65 | call idz_diffsnorm(m,n,matveca,a,dummy,dummy,dummy, 66 | 1 matveca,b,dummy,dummy,dummy, 67 | 2 matvec,a,dummy,dummy,dummy, 68 | 3 matvec,b,dummy,dummy,dummy,its,diffsnorm,v) 69 | c 70 | c 71 | c Divide diffsnorm by .1d-12*sqrt(m*n) and display it. 72 | c 73 | diffsnorm = diffsnorm/(.1d-12*sqrt(r1*m*n)) 74 | call prin2('diffsnorm (which should be about 1) = *', 75 | 1 diffsnorm,1) 76 | c 77 | c 78 | stop 79 | end 80 | c 81 | c 82 | c 83 | c 84 | subroutine fill(krank,m,n,a) 85 | c 86 | c fills an m x n matrix with suitably decaying singular values, 87 | c and left and right singular vectors taken from the DFT. 88 | c 89 | c input: 90 | c krank -- one less than the rank of the matrix to be constructed 91 | c m -- first dimension of a 92 | c n -- second dimension of a 93 | c 94 | c output: 95 | c a -- filled matrix 96 | c 97 | implicit none 98 | integer krank,j,k,l,m,n 99 | real*8 r1,pi 100 | complex*16 a(m,n),sum,ci 101 | c 102 | r1 = 1 103 | pi = 4*atan(r1) 104 | ci = (0,1) 105 | c 106 | c 107 | do k = 1,n 108 | do j = 1,m 109 | c 110 | sum = 0 111 | c 112 | do l = 1,krank 113 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 114 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 115 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 116 | enddo ! l 117 | c 118 | l = krank+1 119 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 120 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 121 | 2 *1d-10 122 | c 123 | a(j,k) = sum*2 124 | c 125 | enddo ! j 126 | enddo ! k 127 | c 128 | c 129 | return 130 | end 131 | c 132 | c 133 | c 134 | c 135 | subroutine matveca(m,x,n,y,a,p2,p3,p4) 136 | c 137 | c applies the adjoint of a to x, obtaining y. 138 | c 139 | c input: 140 | c m -- first dimension of a, and length of x 141 | c x -- vector to which a^* is to be applied 142 | c n -- second dimension of a, and length of y 143 | c a -- matrix whose adjoint is to be applied to x 144 | c in order to create y 145 | c p2 -- dummy input 146 | c p3 -- dummy input 147 | c p4 -- dummy input 148 | c 149 | c output: 150 | c y -- product of a^* and x 151 | c 152 | implicit none 153 | integer m,n,j,k 154 | complex*16 a(m,n),p2,p3,p4,x(m),y(n),sum 155 | c 156 | c 157 | do k = 1,n 158 | c 159 | sum = 0 160 | c 161 | do j = 1,m 162 | sum = sum+conjg(a(j,k))*x(j) 163 | enddo ! j 164 | c 165 | y(k) = sum 166 | c 167 | enddo ! k 168 | c 169 | c 170 | return 171 | end 172 | c 173 | c 174 | c 175 | c 176 | subroutine matvec(n,x,m,y,a,p2,p3,p4) 177 | c 178 | c applies a to x, obtaining y. 179 | c 180 | c input: 181 | c m -- first dimension of a, and length of x 182 | c x -- vector to which a is to be applied 183 | c n -- second dimension of a, and length of y 184 | c a -- matrix to be applied to x in order to create y 185 | c p2 -- dummy input 186 | c p3 -- dummy input 187 | c p4 -- dummy input 188 | c 189 | c output: 190 | c y -- product of a and x 191 | c 192 | implicit none 193 | integer m,n,j,k 194 | complex*16 a(m,n),p2,p3,p4,x(n),y(m),sum 195 | c 196 | c 197 | do j = 1,m 198 | c 199 | sum = 0 200 | c 201 | do k = 1,n 202 | sum = sum+a(j,k)*x(k) 203 | enddo ! k 204 | c 205 | y(j) = sum 206 | c 207 | enddo ! j 208 | c 209 | c 210 | return 211 | end 212 | c 213 | c 214 | c 215 | c 216 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 217 | c 218 | c 219 | c The above code is for testing and debugging; the remainder of 220 | c this file contains the following user-callable routines: 221 | -------------------------------------------------------------------------------- /external/id_dist/test/idzp_aid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idz_house, idz_qrpiv, idz_id, id_rand, 4 | c idz_sfft, id_rtrans, idz_frm, dfft 5 | c 6 | c 7 | implicit none 8 | c 9 | integer len 10 | parameter(len = 1 000 000) 11 | c 12 | integer m,n,krank,list(len),n2 13 | real*8 errmax,errrms,eps 14 | complex*16 a(len),col(len),work(len),proj(len),b(len) 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | c 36 | c 37 | c Initialize the array work for use in idzp_aid. 38 | c 39 | call idz_frmi(m,n2,work) 40 | c 41 | c 42 | c ID a via a randomized algorithm. 43 | c 44 | eps = .1d-10 45 | call idzp_aid(eps,m,n,a,work,krank,list,proj) 46 | call prinf('list = *',list,krank) 47 | c 48 | c 49 | c Collect together the columns of a indexed by list into col. 50 | c 51 | call idz_copycols(m,n,a,krank,list,col) 52 | c 53 | c 54 | c Reconstruct a, obtaining b. 55 | c 56 | call idz_reconid(m,krank,col,n,list,proj,b) 57 | c 58 | c 59 | c Compute the difference between a and b. 60 | c 61 | call materr(m,n,a,b,errmax,errrms) 62 | call prin2('errmax = *',errmax,1) 63 | call prin2('errrms = *',errrms,1) 64 | c 65 | c 66 | stop 67 | end 68 | c 69 | c 70 | c 71 | c 72 | subroutine fill(krank,m,n,a) 73 | c 74 | c fills an m x n matrix with suitably decaying singular values, 75 | c and left and right singular vectors taken from the DFT. 76 | c 77 | c input: 78 | c krank -- rank of the matrix to be constructed 79 | c m -- first dimension of a 80 | c n -- second dimension of a 81 | c 82 | c output: 83 | c a -- filled matrix 84 | c 85 | implicit none 86 | integer krank,j,k,l,m,n 87 | real*8 r1,pi 88 | complex*16 a(m,n),sum,ci 89 | c 90 | r1 = 1 91 | pi = 4*atan(r1) 92 | ci = (0,1) 93 | c 94 | c 95 | do k = 1,n 96 | do j = 1,m 97 | c 98 | sum = 0 99 | c 100 | do l = 1,krank 101 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 102 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 103 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 104 | enddo ! l 105 | c 106 | a(j,k) = sum 107 | c 108 | enddo ! j 109 | enddo ! k 110 | c 111 | c 112 | return 113 | end 114 | c 115 | c 116 | c 117 | c 118 | subroutine materr(m,n,a,b,errmax,errrms) 119 | c 120 | c calculates the relative maximum and root-mean-square errors 121 | c corresponding to how much a and b differ. 122 | c 123 | c input: 124 | c m -- first dimension of a and b 125 | c n -- second dimension of a and b 126 | c a -- matrix whose difference from b will be measured 127 | c b -- matrix whose difference from a will be measured 128 | c 129 | c output: 130 | c errmax -- ratio of the maximum elementwise absolute difference 131 | c between a and b to the maximum magnitude 132 | c of all the elements of a 133 | c errrms -- ratio of the root-mean-square of the elements 134 | c of the difference of a and b to the root-mean-square 135 | c of all the elements of a 136 | c 137 | implicit none 138 | integer m,n,j,k 139 | real*8 errmax,errrms,diff,amax,arss 140 | complex*16 a(m,n),b(m,n) 141 | c 142 | c 143 | c Calculate the maximum magnitude amax of the elements of a 144 | c and the root-sum-square arss of the elements of a. 145 | c 146 | amax = 0 147 | arss = 0 148 | c 149 | do k = 1,n 150 | do j = 1,m 151 | c 152 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 153 | arss = arss+a(j,k)*conjg(a(j,k)) 154 | c 155 | enddo ! j 156 | enddo ! k 157 | c 158 | arss = sqrt(arss) 159 | c 160 | c 161 | c Calculate the maximum elementwise absolute difference 162 | c between a and b, as well as the root-sum-square errrms 163 | c of the elements of the difference of a and b. 164 | c 165 | errmax = 0 166 | errrms = 0 167 | c 168 | do k = 1,n 169 | do j = 1,m 170 | c 171 | diff = abs(a(j,k)-b(j,k)) 172 | c 173 | if(diff .gt. errmax) errmax = diff 174 | errrms = errrms+diff**2 175 | c 176 | enddo ! j 177 | enddo ! k 178 | c 179 | errrms = sqrt(errrms) 180 | c 181 | c 182 | c Calculate relative errors. 183 | c 184 | errmax = errmax/amax 185 | errrms = errrms/arss 186 | c 187 | c 188 | return 189 | end 190 | c 191 | c 192 | c 193 | c 194 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 195 | c 196 | c 197 | c The above code is for testing and debugging; the remainder of 198 | c this file contains the following user-callable routines: 199 | -------------------------------------------------------------------------------- /external/id_dist/test/idzp_rid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idz_house, idz_qrpiv, idz_id, id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,krank,list(len),ier,lproj 12 | real*8 errmax,errrms,eps 13 | complex*16 a(len),p2,p3,p4,col(len),proj(len),b(len) 14 | external matveca 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | c 36 | c 37 | c ID a via a randomized algorithm. 38 | c 39 | eps = .1d-12 40 | lproj = len 41 | c 42 | call idzp_rid(lproj,eps,m,n,matveca,a,p2,p3,p4, 43 | 1 krank,list,proj,ier) 44 | c 45 | call prinf('ier = *',ier,1) 46 | call prinf('list = *',list,krank) 47 | c 48 | c 49 | c Collect together the columns of a indexed by list into col. 50 | c 51 | call idz_copycols(m,n,a,krank,list,col) 52 | c 53 | c 54 | c Reconstruct a, obtaining b. 55 | c 56 | call idz_reconid(m,krank,col,n,list,proj,b) 57 | c 58 | c 59 | c Compute the difference between a and b. 60 | c 61 | call materr(m,n,a,b,errmax,errrms) 62 | call prin2('errmax = *',errmax,1) 63 | call prin2('errrms = *',errrms,1) 64 | c 65 | c 66 | stop 67 | end 68 | c 69 | c 70 | c 71 | c 72 | subroutine fill(krank,m,n,a) 73 | c 74 | c fills an m x n matrix with suitably decaying singular values, 75 | c and left and right singular vectors taken from the DFT. 76 | c 77 | c input: 78 | c krank -- rank of the matrix to be constructed 79 | c m -- first dimension of a 80 | c n -- second dimension of a 81 | c 82 | c output: 83 | c a -- filled matrix 84 | c 85 | implicit none 86 | integer krank,j,k,l,m,n 87 | real*8 r1,pi 88 | complex*16 a(m,n),sum,ci 89 | c 90 | r1 = 1 91 | pi = 4*atan(r1) 92 | ci = (0,1) 93 | c 94 | c 95 | do k = 1,n 96 | do j = 1,m 97 | c 98 | sum = 0 99 | c 100 | do l = 1,krank 101 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 102 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 103 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 104 | enddo ! l 105 | c 106 | a(j,k) = sum 107 | c 108 | enddo ! j 109 | enddo ! k 110 | c 111 | c 112 | return 113 | end 114 | c 115 | c 116 | c 117 | c 118 | subroutine materr(m,n,a,b,errmax,errrms) 119 | c 120 | c calculates the relative maximum and root-mean-square errors 121 | c corresponding to how much a and b differ. 122 | c 123 | c input: 124 | c m -- first dimension of a and b 125 | c n -- second dimension of a and b 126 | c a -- matrix whose difference from b will be measured 127 | c b -- matrix whose difference from a will be measured 128 | c 129 | c output: 130 | c errmax -- ratio of the maximum elementwise absolute difference 131 | c between a and b to the maximum magnitude 132 | c of all the elements of a 133 | c errrms -- ratio of the root-mean-square of the elements 134 | c of the difference of a and b to the root-mean-square 135 | c of all the elements of a 136 | c 137 | implicit none 138 | integer m,n,j,k 139 | real*8 errmax,errrms,diff,amax,arss 140 | complex*16 a(m,n),b(m,n) 141 | c 142 | c 143 | c Calculate the maximum magnitude amax of the elements of a 144 | c and the root-sum-square arss of the elements of a. 145 | c 146 | amax = 0 147 | arss = 0 148 | c 149 | do k = 1,n 150 | do j = 1,m 151 | c 152 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 153 | arss = arss+a(j,k)*conjg(a(j,k)) 154 | c 155 | enddo ! j 156 | enddo ! k 157 | c 158 | arss = sqrt(arss) 159 | c 160 | c 161 | c Calculate the maximum elementwise absolute difference 162 | c between a and b, as well as the root-sum-square errrms 163 | c of the elements of the difference of a and b. 164 | c 165 | errmax = 0 166 | errrms = 0 167 | c 168 | do k = 1,n 169 | do j = 1,m 170 | c 171 | diff = abs(a(j,k)-b(j,k)) 172 | c 173 | if(diff .gt. errmax) errmax = diff 174 | errrms = errrms+diff**2 175 | c 176 | enddo ! j 177 | enddo ! k 178 | c 179 | errrms = sqrt(errrms) 180 | c 181 | c 182 | c Calculate relative errors. 183 | c 184 | errmax = errmax/amax 185 | errrms = errrms/arss 186 | c 187 | c 188 | return 189 | end 190 | c 191 | c 192 | c 193 | c 194 | subroutine matveca(m,x,n,y,a,p2,p3,p4) 195 | c 196 | c applies the adjoint of a to x, obtaining y. 197 | c 198 | c input: 199 | c m -- first dimension of a, and length of x 200 | c x -- vector to which a^* is to be applied 201 | c n -- second dimension of a, and length of y 202 | c a -- matrix whose adjoint is to be applied to x 203 | c in order to create y 204 | c p2 -- dummy input 205 | c p3 -- dummy input 206 | c p4 -- dummy input 207 | c 208 | c output: 209 | c y -- product of a^* and x 210 | c 211 | implicit none 212 | integer m,n,j,k 213 | complex*16 a(m,n),p2,p3,p4,x(m),y(n),sum 214 | c 215 | c 216 | do k = 1,n 217 | c 218 | sum = 0 219 | c 220 | do j = 1,m 221 | sum = sum+conjg(a(j,k))*x(j) 222 | enddo ! j 223 | c 224 | y(k) = sum 225 | c 226 | enddo ! k 227 | c 228 | c 229 | return 230 | end 231 | c 232 | c 233 | c 234 | c 235 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 236 | c 237 | c 238 | c The above code is for testing and debugging; the remainder of 239 | c this file contains the following user-callable routines: 240 | -------------------------------------------------------------------------------- /external/id_dist/test/idzr_aid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idz_house, idz_qrpiv, idz_id, id_rand, 4 | c idz_sfft, id_rtrans, idz_frm, dfft 5 | c 6 | c 7 | implicit none 8 | c 9 | integer len 10 | parameter(len = 1 000 000) 11 | c 12 | integer m,n,krank,list(len) 13 | real*8 errmax,errrms 14 | complex*16 a(len),b(len),proj(len),col(len) 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | call prin2('a = *',a,2*m*n) 36 | c 37 | c 38 | c Initialize b as the work array for idzr_aid. 39 | c 40 | call idzr_aidi(m,n,krank,b) 41 | c 42 | c 43 | c ID a. 44 | c 45 | call idzr_aid(m,n,a,krank,b,list,proj) 46 | call prinf('list = *',list,krank) 47 | c 48 | c 49 | c Collect together the columns of a indexed by list into col. 50 | c 51 | call idz_copycols(m,n,a,krank,list,col) 52 | c 53 | c 54 | c Reconstruct a, obtaining b. 55 | c 56 | call idz_reconid(m,krank,col,n,list,proj,b) 57 | c 58 | c 59 | c Compute the difference between a and b. 60 | c 61 | call materr(m,n,a,b,errmax,errrms) 62 | call prin2('errmax = *',errmax,1) 63 | call prin2('errrms = *',errrms,1) 64 | c 65 | c 66 | stop 67 | end 68 | c 69 | c 70 | c 71 | c 72 | subroutine fill(krank,m,n,a) 73 | c 74 | c fills an m x n matrix with suitably decaying singular values, 75 | c and left and right singular vectors taken from the DFT. 76 | c 77 | c input: 78 | c krank -- one less than the rank of the matrix to be constructed 79 | c m -- first dimension of a 80 | c n -- second dimension of a 81 | c 82 | c output: 83 | c a -- filled matrix 84 | c 85 | implicit none 86 | integer krank,j,k,l,m,n 87 | real*8 r1,pi 88 | complex*16 a(m,n),sum,ci 89 | c 90 | r1 = 1 91 | pi = 4*atan(r1) 92 | ci = (0,1) 93 | c 94 | c 95 | do k = 1,n 96 | do j = 1,m 97 | c 98 | sum = 0 99 | c 100 | do l = 1,krank 101 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 102 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 103 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 104 | enddo ! l 105 | c 106 | l = krank+1 107 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 108 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 109 | 2 *1d-10 110 | c 111 | a(j,k) = sum 112 | c 113 | enddo ! j 114 | enddo ! k 115 | c 116 | c 117 | return 118 | end 119 | c 120 | c 121 | c 122 | c 123 | subroutine materr(m,n,a,b,errmax,errrms) 124 | c 125 | c calculates the relative maximum and root-mean-square errors 126 | c corresponding to how much a and b differ. 127 | c 128 | c input: 129 | c m -- first dimension of a and b 130 | c n -- second dimension of a and b 131 | c a -- matrix whose difference from b will be measured 132 | c b -- matrix whose difference from a will be measured 133 | c 134 | c output: 135 | c errmax -- ratio of the maximum elementwise absolute difference 136 | c between a and b to the maximum magnitude 137 | c of all the elements of a 138 | c errrms -- ratio of the root-mean-square of the elements 139 | c of the difference of a and b to the root-mean-square 140 | c of all the elements of a 141 | c 142 | implicit none 143 | integer m,n,j,k 144 | real*8 errmax,errrms,diff,amax,arss 145 | complex*16 a(m,n),b(m,n) 146 | c 147 | c 148 | c Calculate the maximum magnitude amax of the elements of a 149 | c and the root-sum-square arss of the elements of a. 150 | c 151 | amax = 0 152 | arss = 0 153 | c 154 | do k = 1,n 155 | do j = 1,m 156 | c 157 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 158 | arss = arss+a(j,k)*conjg(a(j,k)) 159 | c 160 | enddo ! j 161 | enddo ! k 162 | c 163 | arss = sqrt(arss) 164 | c 165 | c 166 | c Calculate the maximum elementwise absolute difference 167 | c between a and b, as well as the root-sum-square errrms 168 | c of the elements of the difference of a and b. 169 | c 170 | errmax = 0 171 | errrms = 0 172 | c 173 | do k = 1,n 174 | do j = 1,m 175 | c 176 | diff = abs(a(j,k)-b(j,k)) 177 | c 178 | if(diff .gt. errmax) errmax = diff 179 | errrms = errrms+diff**2 180 | c 181 | enddo ! j 182 | enddo ! k 183 | c 184 | errrms = sqrt(errrms) 185 | c 186 | c 187 | c Calculate relative errors. 188 | c 189 | errmax = errmax/amax 190 | errrms = errrms/arss 191 | c 192 | c 193 | return 194 | end 195 | c 196 | c 197 | c 198 | c 199 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 200 | c 201 | c 202 | c The above code is for testing and debugging; the remainder of 203 | c this file contains the following user-callable routines: 204 | -------------------------------------------------------------------------------- /external/id_dist/test/idzr_asvd_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idz_house, idz_qrpiv, idz_id, id_rand, 4 | c idz_sfft, id_rtrans, idz_frm, idzr_aid, 5 | c idz_id2svd, dfft, lapack.a, blas.a 6 | c 7 | c 8 | implicit none 9 | c 10 | integer len 11 | parameter(len = 1 000 000) 12 | c 13 | integer m,n,krank,ier 14 | real*8 errmax,errrms,s(100 000) 15 | complex*16 a(len),b(len),u(len),v(len),w(len) 16 | c 17 | c 18 | call prini(6,13) 19 | c 20 | c 21 | print *,'Enter m:' 22 | read *,m 23 | call prinf('m = *',m,1) 24 | c 25 | print *,'Enter n:' 26 | read *,n 27 | call prinf('n = *',n,1) 28 | c 29 | krank = 5 30 | call prinf('krank = *',krank,1) 31 | c 32 | c 33 | c Fill a. 34 | c 35 | call fill(krank,m,n,a,s) 36 | call prin2('a = *',a,m*n) 37 | call prin2('s = *',s,krank+1) 38 | c 39 | c 40 | c Calculate an SVD approximating a. 41 | c 42 | call idzr_aidi(m,n,krank,w) 43 | call idzr_asvd(m,n,a,krank,w,u,v,s,ier) 44 | c 45 | c 46 | c Construct b = u diag(s) v^*. 47 | c 48 | call reconsvd(m,krank,u,s,n,v,b) 49 | c 50 | c 51 | c Compute the difference between a and b. 52 | c 53 | call materr(m,n,a,b,errmax,errrms) 54 | call prin2('errmax = *',errmax,1) 55 | call prin2('errrms = *',errrms,1) 56 | c 57 | c 58 | stop 59 | end 60 | c 61 | c 62 | c 63 | c 64 | subroutine fill(krank,m,n,a,s) 65 | c 66 | c fills an m x n matrix with suitably decaying singular values, 67 | c and left and right singular vectors taken from the DFT. 68 | c 69 | c input: 70 | c krank -- one less than the rank of the matrix to be constructed 71 | c m -- first dimension of a 72 | c n -- second dimension of a 73 | c 74 | c output: 75 | c a -- filled matrix 76 | c s -- singular values of a 77 | c 78 | implicit none 79 | integer krank,j,k,l,m,n 80 | real*8 r1,pi,s(krank+1) 81 | complex*16 a(m,n),sum,ci 82 | c 83 | r1 = 1 84 | pi = 4*atan(r1) 85 | ci = (0,1) 86 | c 87 | c 88 | c Specify the singular values. 89 | c 90 | do k = 1,krank 91 | s(k) = exp(log(1d-10)*(k-1)/(krank-1)) 92 | enddo ! k 93 | c 94 | s(krank+1) = 1d-10 95 | c 96 | c 97 | c Construct a. 98 | c 99 | do k = 1,n 100 | do j = 1,m 101 | c 102 | sum = 0 103 | c 104 | do l = 1,krank 105 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 106 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n)*s(l) 107 | enddo ! l 108 | c 109 | l = krank+1 110 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 111 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n)*s(l) 112 | c 113 | a(j,k) = sum 114 | c 115 | enddo ! j 116 | enddo ! k 117 | c 118 | c 119 | return 120 | end 121 | c 122 | c 123 | c 124 | c 125 | subroutine materr(m,n,a,b,errmax,errrms) 126 | c 127 | c calculates the relative maximum and root-mean-square errors 128 | c corresponding to how much a and b differ. 129 | c 130 | c input: 131 | c m -- first dimension of a and b 132 | c n -- second dimension of a and b 133 | c a -- matrix whose difference from b will be measured 134 | c b -- matrix whose difference from a will be measured 135 | c 136 | c output: 137 | c errmax -- ratio of the maximum elementwise absolute difference 138 | c between a and b to the maximum magnitude 139 | c of all the elements of a 140 | c errrms -- ratio of the root-mean-square of the elements 141 | c of the difference of a and b to the root-mean-square 142 | c of all the elements of a 143 | c 144 | implicit none 145 | integer m,n,j,k 146 | real*8 errmax,errrms,diff,amax,arss 147 | complex*16 a(m,n),b(m,n) 148 | c 149 | c 150 | c Calculate the maximum magnitude amax of the elements of a 151 | c and the root-sum-square arss of the elements of a. 152 | c 153 | amax = 0 154 | arss = 0 155 | c 156 | do k = 1,n 157 | do j = 1,m 158 | c 159 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 160 | arss = arss+a(j,k)*conjg(a(j,k)) 161 | c 162 | enddo ! j 163 | enddo ! k 164 | c 165 | arss = sqrt(arss) 166 | c 167 | c 168 | c Calculate the maximum elementwise absolute difference 169 | c between a and b, as well as the root-sum-square errrms 170 | c of the elements of the difference of a and b. 171 | c 172 | errmax = 0 173 | errrms = 0 174 | c 175 | do k = 1,n 176 | do j = 1,m 177 | c 178 | diff = abs(a(j,k)-b(j,k)) 179 | c 180 | if(diff .gt. errmax) errmax = diff 181 | errrms = errrms+diff**2 182 | c 183 | enddo ! j 184 | enddo ! k 185 | c 186 | errrms = sqrt(errrms) 187 | c 188 | c 189 | c Calculate relative errors. 190 | c 191 | errmax = errmax/amax 192 | errrms = errrms/arss 193 | c 194 | c 195 | return 196 | end 197 | c 198 | c 199 | c 200 | c 201 | subroutine reconsvd(m,krank,u,s,n,v,a) 202 | c 203 | c forms a = u diag(s) v^*. 204 | c 205 | c input: 206 | c m -- first dimension of u and a 207 | c krank -- size of s, and second dimension of u and v 208 | c u -- leftmost matrix in the product a = u diag(s) v^* 209 | c s -- entries on the diagonal in the middle matrix 210 | c in the product a = u diag(s) v^* 211 | c n -- second dimension of a and first dimension of v 212 | c v -- rightmost matrix in the product a = u diag(s) v^* 213 | c 214 | c output: 215 | c a -- matrix product u diag(s) v^* 216 | c 217 | implicit none 218 | integer m,n,krank,j,k,l 219 | real*8 s(krank) 220 | complex*16 u(m,krank),v(n,krank),a(m,n),sum 221 | c 222 | c 223 | do k = 1,n 224 | do j = 1,m 225 | c 226 | sum = 0 227 | c 228 | do l = 1,krank 229 | sum = sum+u(j,l)*s(l)*conjg(v(k,l)) 230 | enddo ! l 231 | c 232 | a(j,k) = sum 233 | c 234 | enddo ! j 235 | enddo ! k 236 | c 237 | c 238 | return 239 | end 240 | c 241 | c 242 | c 243 | c 244 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 245 | c 246 | c 247 | c The above code is for testing and debugging; the remainder of 248 | c this file contains the following user-callable routines: 249 | -------------------------------------------------------------------------------- /external/id_dist/test/idzr_rid_test.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c dependencies: prini, idz_house, idz_qrpiv, idz_id, id_rand 4 | c 5 | c 6 | implicit none 7 | c 8 | integer len 9 | parameter(len = 1 000 000) 10 | c 11 | integer m,n,krank,list(len) 12 | real*8 errmax,errrms 13 | complex*16 a(len),p2,p3,p4,b(len),proj(len),col(len) 14 | external matveca 15 | c 16 | c 17 | call prini(6,13) 18 | c 19 | c 20 | print *,'Enter m:' 21 | read *,m 22 | call prinf('m = *',m,1) 23 | c 24 | print *,'Enter n:' 25 | read *,n 26 | call prinf('n = *',n,1) 27 | c 28 | krank = 5 29 | call prinf('krank = *',krank,1) 30 | c 31 | c 32 | c Fill a. 33 | c 34 | call fill(krank,m,n,a) 35 | call prin2('a = *',a,2*m*n) 36 | c 37 | c 38 | c ID a. 39 | c 40 | call idzr_rid(m,n,matveca,a,p2,p3,p4,krank,list,proj) 41 | call prinf('list = *',list,krank) 42 | c 43 | c 44 | c Collect together the columns of a indexed by list into col. 45 | c 46 | call idz_copycols(m,n,a,krank,list,col) 47 | c 48 | c 49 | c Reconstruct a, obtaining b. 50 | c 51 | call idz_reconid(m,krank,col,n,list,proj,b) 52 | c 53 | c 54 | c Compute the difference between a and b. 55 | c 56 | call materr(m,n,a,b,errmax,errrms) 57 | call prin2('errmax = *',errmax,1) 58 | call prin2('errrms = *',errrms,1) 59 | c 60 | c 61 | stop 62 | end 63 | c 64 | c 65 | c 66 | c 67 | subroutine fill(krank,m,n,a) 68 | c 69 | c fills an m x n matrix with suitably decaying singular values, 70 | c and left and right singular vectors taken from the DFT. 71 | c 72 | c input: 73 | c krank -- one less than the rank of the matrix to be constructed 74 | c m -- first dimension of a 75 | c n -- second dimension of a 76 | c 77 | c output: 78 | c a -- filled matrix 79 | c 80 | implicit none 81 | integer krank,j,k,l,m,n 82 | real*8 r1,pi 83 | complex*16 a(m,n),sum,ci 84 | c 85 | r1 = 1 86 | pi = 4*atan(r1) 87 | ci = (0,1) 88 | c 89 | c 90 | do k = 1,n 91 | do j = 1,m 92 | c 93 | sum = 0 94 | c 95 | do l = 1,krank 96 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 97 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 98 | 2 *exp(log(1d-10)*(l-1)/(krank-1)) 99 | enddo ! l 100 | c 101 | l = krank+1 102 | sum = sum+exp(2*pi*ci*(j-r1)*(l-r1)/m)*sqrt(r1/m) 103 | 1 *exp(2*pi*ci*(k-r1)*(l-r1)/n)*sqrt(r1/n) 104 | 2 *1d-10 105 | c 106 | a(j,k) = sum 107 | c 108 | enddo ! j 109 | enddo ! k 110 | c 111 | c 112 | return 113 | end 114 | c 115 | c 116 | c 117 | c 118 | subroutine materr(m,n,a,b,errmax,errrms) 119 | c 120 | c calculates the relative maximum and root-mean-square errors 121 | c corresponding to how much a and b differ. 122 | c 123 | c input: 124 | c m -- first dimension of a and b 125 | c n -- second dimension of a and b 126 | c a -- matrix whose difference from b will be measured 127 | c b -- matrix whose difference from a will be measured 128 | c 129 | c output: 130 | c errmax -- ratio of the maximum elementwise absolute difference 131 | c between a and b to the maximum magnitude 132 | c of all the elements of a 133 | c errrms -- ratio of the root-mean-square of the elements 134 | c of the difference of a and b to the root-mean-square 135 | c of all the elements of a 136 | c 137 | implicit none 138 | integer m,n,j,k 139 | real*8 errmax,errrms,diff,amax,arss 140 | complex*16 a(m,n),b(m,n) 141 | c 142 | c 143 | c Calculate the maximum magnitude amax of the elements of a 144 | c and the root-sum-square arss of the elements of a. 145 | c 146 | amax = 0 147 | arss = 0 148 | c 149 | do k = 1,n 150 | do j = 1,m 151 | c 152 | if(abs(a(j,k)) .gt. amax) amax = abs(a(j,k)) 153 | arss = arss+a(j,k)*conjg(a(j,k)) 154 | c 155 | enddo ! j 156 | enddo ! k 157 | c 158 | arss = sqrt(arss) 159 | c 160 | c 161 | c Calculate the maximum elementwise absolute difference 162 | c between a and b, as well as the root-sum-square errrms 163 | c of the elements of the difference of a and b. 164 | c 165 | errmax = 0 166 | errrms = 0 167 | c 168 | do k = 1,n 169 | do j = 1,m 170 | c 171 | diff = abs(a(j,k)-b(j,k)) 172 | c 173 | if(diff .gt. errmax) errmax = diff 174 | errrms = errrms+diff**2 175 | c 176 | enddo ! j 177 | enddo ! k 178 | c 179 | errrms = sqrt(errrms) 180 | c 181 | c 182 | c Calculate relative errors. 183 | c 184 | errmax = errmax/amax 185 | errrms = errrms/arss 186 | c 187 | c 188 | return 189 | end 190 | c 191 | c 192 | c 193 | c 194 | subroutine matveca(m,x,n,y,a,p2,p3,p4) 195 | c 196 | c applies the adjoint of a to x, obtaining y. 197 | c 198 | c input: 199 | c m -- first dimension of a, and length of x 200 | c x -- vector to which a^* is to be applied 201 | c n -- second dimension of a, and length of y 202 | c a -- matrix whose adjoint is to be applied to x 203 | c in order to create y 204 | c p2 -- dummy input 205 | c p3 -- dummy input 206 | c p4 -- dummy input 207 | c 208 | c output: 209 | c y -- product of a^* and x 210 | c 211 | implicit none 212 | integer m,n,j,k 213 | complex*16 a(m,n),p2,p3,p4,x(m),y(n),sum 214 | c 215 | c 216 | do k = 1,n 217 | c 218 | sum = 0 219 | c 220 | do j = 1,m 221 | sum = sum+conjg(a(j,k))*x(j) 222 | enddo ! j 223 | c 224 | y(k) = sum 225 | c 226 | enddo ! k 227 | c 228 | c 229 | return 230 | end 231 | c 232 | c 233 | c 234 | c 235 | ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 236 | c 237 | c 238 | c The above code is for testing and debugging; the remainder of 239 | c this file contains the following user-callable routines: 240 | -------------------------------------------------------------------------------- /external/id_dist/tmp/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/klho/PyMatrixID/3bdc86a36efd0628c031ae7fb31acaa810e801c3/external/id_dist/tmp/.gitignore --------------------------------------------------------------------------------