├── .github └── workflows │ ├── cmake.yml │ ├── doc-deployment.yml │ └── fpm.yml ├── .gitignore ├── CMakeLists.txt ├── LICENSE ├── README.md ├── cmake └── helper.cmake ├── configure └── CMakeLists.txt ├── dependencies ├── CMakeLists.txt └── ferror │ └── CMakeLists.txt ├── doc ├── css │ ├── font-awesome.css │ ├── font-awesome.min.css │ ├── local.css │ └── pygments.css ├── favicon.png ├── fonts │ ├── FontAwesome.otf │ ├── fontawesome-webfont.eot │ ├── fontawesome-webfont.svg │ ├── fontawesome-webfont.ttf │ ├── fontawesome-webfont.woff │ ├── glyphicons-halflings-regular.eot │ ├── glyphicons-halflings-regular.svg │ ├── glyphicons-halflings-regular.ttf │ └── glyphicons-halflings-regular.woff ├── index.html ├── interface │ ├── assignment(=).html │ ├── band_diag_mtx_mult.html │ ├── band_mtx_mult.html │ ├── band_mtx_to_full_mtx.html │ ├── banded_to_dense.html │ ├── cholesky_factor.html │ ├── cholesky_rank1_downdate.html │ ├── cholesky_rank1_update.html │ ├── dense_to_banded.html │ ├── det.html │ ├── diag_mtx_mult.html │ ├── eigen.html │ ├── extract_diagonal.html │ ├── form_lq.html │ ├── form_lu.html │ ├── form_qr.html │ ├── lq_factor.html │ ├── lu_factor.html │ ├── matmul.html │ ├── mtx_inverse.html │ ├── mtx_mult.html │ ├── mtx_pinverse.html │ ├── mtx_rank.html │ ├── mult_lq.html │ ├── mult_qr.html │ ├── mult_rz.html │ ├── nonzero_count.html │ ├── operator(+).html │ ├── operator(-).html │ ├── operator(ASTERISK).html │ ├── operator(SLASH).html │ ├── pgmres_solver.html │ ├── qr_factor.html │ ├── qr_rank1_update.html │ ├── rank1_update.html │ ├── recip_mult_array.html │ ├── rz_factor.html │ ├── size.html │ ├── solve_cholesky.html │ ├── solve_least_squares.html │ ├── solve_least_squares_full.html │ ├── solve_least_squares_svd.html │ ├── solve_lq.html │ ├── solve_lu.html │ ├── solve_qr.html │ ├── solve_triangular_system.html │ ├── sort.html │ ├── sparse_direct_solve.html │ ├── svd.html │ ├── swap.html │ ├── trace.html │ ├── transpose.html │ └── tri_mtx_mult.html ├── js │ ├── MathJax-config │ │ └── .gitignore │ └── svg-pan-zoom.min.js ├── lists │ ├── files.html │ ├── modules.html │ ├── procedures.html │ └── types.html ├── module │ ├── linalg.html │ ├── linalg_basic.html │ ├── linalg_cholesky.html │ ├── linalg_eigen.html │ ├── linalg_errors.html │ ├── linalg_inverse.html │ ├── linalg_least_squares.html │ ├── linalg_lq.html │ ├── linalg_lu.html │ ├── linalg_qr.html │ ├── linalg_rz.html │ ├── linalg_sorting.html │ ├── linalg_sparse.html │ ├── linalg_svd.html │ └── linalg_tri.html ├── proc │ ├── banded_to_csr.html │ ├── create_csr_matrix.html │ ├── create_empty_csr_matrix.html │ ├── create_empty_msr_matrix.html │ ├── csr_to_dense.html │ ├── csr_to_msr.html │ ├── dense_to_csr.html │ ├── dense_to_msr.html │ ├── diag_to_csr.html │ ├── msr_to_csr.html │ ├── msr_to_dense.html │ ├── report_array_size_error.html │ ├── report_inner_matrix_dimension_error.html │ ├── report_matrix_size_error.html │ ├── report_memory_error.html │ ├── report_singular_matrix_warning.html │ └── report_square_matrix_error.html ├── search.html ├── sourcefile │ ├── linalg.f90.html │ ├── linalg_basic.f90.html │ ├── linalg_cholesky.f90.html │ ├── linalg_eigen.f90.html │ ├── linalg_errors.f90.html │ ├── linalg_inverse.f90.html │ ├── linalg_least_squares.f90.html │ ├── linalg_lq.f90.html │ ├── linalg_lu.f90.html │ ├── linalg_qr.f90.html │ ├── linalg_rz.f90.html │ ├── linalg_sorting.f90.html │ ├── linalg_sparse.f90.html │ ├── linalg_svd.f90.html │ └── linalg_tri.f90.html ├── src │ ├── linalg.f90 │ ├── linalg_basic.f90 │ ├── linalg_cholesky.f90 │ ├── linalg_eigen.f90 │ ├── linalg_errors.f90 │ ├── linalg_inverse.f90 │ ├── linalg_least_squares.f90 │ ├── linalg_lq.f90 │ ├── linalg_lu.f90 │ ├── linalg_qr.f90 │ ├── linalg_rz.f90 │ ├── linalg_sorting.f90 │ ├── linalg_sparse.f90 │ ├── linalg_svd.f90 │ └── linalg_tri.f90 ├── tipuesearch │ ├── .DS_Store │ ├── img │ │ ├── .DS_Store │ │ ├── loader.gif │ │ └── search.png │ ├── tipuesearch.css │ ├── tipuesearch.js │ ├── tipuesearch.min.js │ ├── tipuesearch_content.js │ └── tipuesearch_set.js └── type │ ├── csr_matrix.html │ └── msr_matrix.html ├── docs.md ├── examples ├── CMakeLists.txt ├── c_linalg_eigen_example.c ├── c_linalg_lu_example.c ├── linalg_cholesky_downdate_example.f90 ├── linalg_cholesky_example.f90 ├── linalg_cholesky_update_example.f90 ├── linalg_eigen_example.f90 ├── linalg_inverse_example.f90 ├── linalg_lq_example.f90 ├── linalg_lq_full_example.f90 ├── linalg_lq_mult_example.f90 ├── linalg_lu_example.f90 ├── linalg_lu_full_example.f90 ├── linalg_od_example.f90 ├── linalg_pinverse_example.f90 ├── linalg_qr_example.f90 ├── linalg_qr_full_example.f90 ├── linalg_qr_mult_example.f90 ├── linalg_qr_update_example.f90 ├── linalg_sparse_direct_example.f90 └── linalg_svd_example.f90 ├── fpm.toml ├── include └── linalg.h ├── package.json ├── sparskit2 ├── BLASSM │ ├── README │ ├── apl.f │ ├── blassm.f │ ├── matvec.f │ ├── rmatvec.f │ └── tester.f ├── DOC │ ├── QUICK_REF │ ├── README │ ├── dir.eps │ ├── dir.fig │ ├── dir.pdf │ ├── doc_data.txt │ ├── jpwh.pdf │ ├── jpwh.ps │ ├── mat8.pdf │ ├── mat8.ps │ ├── mat9.pdf │ ├── mat9.ps │ ├── msh8.pdf │ ├── msh8.ps │ ├── msh9.pdf │ ├── msh9.ps │ ├── paper.pdf │ ├── paper.ps │ ├── paper.tex │ ├── vbrpic.eps │ ├── vbrpic.fig │ └── vbrpic.pdf ├── FORMATS │ ├── README │ ├── chkfmt1.f │ ├── chkun.f │ ├── formats.f │ ├── rvbr.f │ └── unary.f ├── INFO │ ├── README │ ├── dinfo13.f │ ├── info.saylr1 │ ├── infofun.f │ ├── rinfo1.f │ ├── rinfoC.c │ └── saylr1 ├── INOUT │ ├── README │ ├── chkio.f │ ├── hb2pic.f │ ├── hb2ps.f │ └── inout.f ├── ITSOL │ ├── README │ ├── ilut.f │ ├── itaux.f │ ├── iters.f │ ├── rilut.f │ ├── riter2.f │ ├── riters.f │ ├── runilut.f │ └── saylr1 ├── MATGEN │ ├── FDIF │ │ ├── README │ │ ├── functns.f │ │ ├── genmat.f │ │ ├── rgen5pt.f │ │ └── rgenblk.f │ ├── FEM │ │ ├── README │ │ ├── convdif.f │ │ ├── elmtlib2.f │ │ ├── femgen.f │ │ ├── functns2.f │ │ ├── mat.hb │ │ └── meshes.f │ ├── MISC │ │ ├── README │ │ ├── markov.f │ │ ├── rsobel.f │ │ ├── rzlatev.f │ │ ├── sobel.f │ │ └── zlatev.f │ └── README ├── ORDERINGS │ ├── README │ ├── ccn.f │ ├── color.f │ └── dsepart.f ├── README └── UNSUPP │ ├── BLAS1 │ └── blas1.f │ ├── MATEXP │ ├── README │ ├── exppro.f │ ├── phipro.f │ ├── rexp.f │ └── rphi.f │ ├── PLOTS │ ├── README │ ├── psgrd.f │ ├── texgrid1.f │ └── texplt1.f │ └── README ├── src ├── CMakeLists.txt ├── blas.f90 ├── lapack.f90 ├── linalg.f90 ├── linalg_basic.f90 ├── linalg_c_api.f90 ├── linalg_cholesky.f90 ├── linalg_eigen.f90 ├── linalg_errors.f90 ├── linalg_inverse.f90 ├── linalg_least_squares.f90 ├── linalg_lq.f90 ├── linalg_lu.f90 ├── linalg_qr.f90 ├── linalg_rz.f90 ├── linalg_sorting.f90 ├── linalg_sparse.f90 ├── linalg_svd.f90 ├── linalg_tri.f90 ├── qrupdate.f90 ├── qrupdate │ ├── caxcpy.f │ ├── cch1dn.f │ ├── cch1up.f │ ├── cchdex.f │ ├── cchinx.f │ ├── cchshx.f │ ├── cgqvec.f │ ├── clu1up.f │ ├── clup1up.f │ ├── cqhqr.f │ ├── cqr1up.f │ ├── cqrdec.f │ ├── cqrder.f │ ├── cqrinc.f │ ├── cqrinr.f │ ├── cqrot.f │ ├── cqrqh.f │ ├── cqrshc.f │ ├── cqrtv1.f │ ├── dch1dn.f │ ├── dch1up.f │ ├── dchdex.f │ ├── dchinx.f │ ├── dchshx.f │ ├── dgqvec.f │ ├── dlu1up.f │ ├── dlup1up.f │ ├── dqhqr.f │ ├── dqr1up.f │ ├── dqrdec.f │ ├── dqrder.f │ ├── dqrinc.f │ ├── dqrinr.f │ ├── dqrot.f │ ├── dqrqh.f │ ├── dqrshc.f │ ├── dqrtv1.f │ ├── sch1dn.f │ ├── sch1up.f │ ├── schdex.f │ ├── schinx.f │ ├── schshx.f │ ├── sgqvec.f │ ├── slu1up.f │ ├── slup1up.f │ ├── sqhqr.f │ ├── sqr1up.f │ ├── sqrdec.f │ ├── sqrder.f │ ├── sqrinc.f │ ├── sqrinr.f │ ├── sqrot.f │ ├── sqrqh.f │ ├── sqrshc.f │ ├── sqrtv1.f │ ├── zaxcpy.f │ ├── zch1dn.f │ ├── zch1up.f │ ├── zchdex.f │ ├── zchinx.f │ ├── zchshx.f │ ├── zgqvec.f │ ├── zlu1up.f │ ├── zlup1up.f │ ├── zqhqr.f │ ├── zqr1up.f │ ├── zqrdec.f │ ├── zqrder.f │ ├── zqrinc.f │ ├── zqrinr.f │ ├── zqrot.f │ ├── zqrqh.f │ ├── zqrshc.f │ └── zqrtv1.f ├── sparskit.f90 └── sparskit2 │ ├── blassm.f │ ├── distdot.f │ ├── formats.f │ ├── ilut.f │ ├── iters.f │ ├── matvec.f │ └── unary.f ├── tests ├── CMakeLists.txt ├── fortran_test_helper │ └── CMakeLists.txt ├── linalg_test.f90 ├── test_cholesky.f90 ├── test_core.f90 ├── test_eigen.f90 ├── test_lq.f90 ├── test_lu.f90 ├── test_misc.f90 ├── test_mtx_inverse.f90 ├── test_qr.f90 ├── test_sort.f90 ├── test_sparse.f90 └── test_svd.f90 └── tests_c ├── CMakeLists.txt ├── c_linalg_test.c ├── c_linalg_test.h ├── c_linalg_test_eigen.c ├── c_linalg_test_factor.c ├── c_linalg_test_misc.c ├── c_test_core.c └── c_test_core.h /.github/workflows/cmake.yml: -------------------------------------------------------------------------------- 1 | name: CMake 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | env: 10 | BUILD_TYPE: Release 11 | 12 | jobs: 13 | test: 14 | runs-on: ${{ matrix.os }} 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | os: [ubuntu-latest, macos-latest] 19 | toolchain: 20 | - {compiler: gcc, version: 11} 21 | - {compiler: intel-classic, version: '2021.9'} 22 | include: 23 | - os: ubuntu-latest 24 | toolchain: {compiler: intel, version: '2023.2'} 25 | 26 | steps: 27 | - uses: awvwgk/setup-fortran@v1 28 | id: setup-fortran 29 | with: 30 | compiler: ${{ matrix.toolchain.compiler }} 31 | version: ${{ matrix.toolchain.version }} 32 | 33 | - run: ${{ env.FC }} --version 34 | env: 35 | FC: ${{ steps.setup-fortran.outputs.fc }} 36 | CC: ${{ steps.setup-fortran.outputs.cc }} 37 | 38 | - uses: actions/checkout@v3 39 | 40 | - name: Configure CMake 41 | run: cmake -B ${{github.workspace}}/build -DCMAKE_BUILD_TYPE=${{env.BUILD_TYPE}} -DCMAKE_Fortran_COMPILER=${{ env.FC }} -DBUILD_TESTING=TRUE 42 | 43 | - name: Build with CMake 44 | run: cmake --build ${{github.workspace}}/build --config ${{env.BUILD_TYPE}} 45 | 46 | - name: Test with CMake 47 | working-directory: ${{github.workspace}}/build 48 | run: ctest -C ${{env.BUILD_TYPE}} -------------------------------------------------------------------------------- /.github/workflows/doc-deployment.yml: -------------------------------------------------------------------------------- 1 | name: doc-deployment 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build-and-deploy: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2 10 | - uses: actions/setup-python@v1 11 | with: 12 | python-version: '3.x' 13 | 14 | - name: Install dependencies 15 | run: pip install -v ford==6.1.17 16 | 17 | - name: Build Documentation 18 | run: ford docs.md 19 | 20 | - uses: JamesIves/github-pages-deploy-action@3.7.1 21 | if: github.event_name == 'push' && github.repository == 'jchristopherson/linalg' && ( startsWith( github.ref, 'refs/tags/' ) || github.ref == 'refs/heads/master' ) 22 | with: 23 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 24 | BRANCH: gh-pages 25 | FOLDER: doc 26 | CLEAN: true -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Prerequisites 2 | *.d 3 | 4 | # Compiled Object files 5 | *.slo 6 | *.lo 7 | *.o 8 | *.obj 9 | 10 | # Precompiled Headers 11 | *.gch 12 | *.pch 13 | 14 | # Compiled Dynamic libraries 15 | *.so 16 | *.dylib 17 | *.dll 18 | 19 | # Fortran module files 20 | *.mod 21 | *.smod 22 | 23 | # Compiled Static libraries 24 | *.lai 25 | *.la 26 | *.a 27 | *.lib 28 | 29 | # Executables 30 | *.exe 31 | *.out 32 | *.app 33 | 34 | # Directories 35 | bin/ 36 | lib/ 37 | build/ 38 | latex/ 39 | 40 | 41 | # CMake Stuff 42 | .cmaketools.json 43 | CMakeCache.txt 44 | CMakeFiles 45 | CMakeScripts 46 | Testing 47 | Makefile 48 | cmake_install.cmake 49 | install_manifest.txt 50 | CTestTestfile.cmake 51 | 52 | # VS Code Stuff 53 | launch.json 54 | settings.json -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Master CMAKE Build Script 2 | cmake_minimum_required(VERSION 3.24) 3 | project( 4 | linalg 5 | LANGUAGES Fortran C 6 | VERSION 1.8.3 7 | ) 8 | 9 | # Get helper macros and functions 10 | include("${PROJECT_SOURCE_DIR}/cmake/helper.cmake") 11 | 12 | # Build the C API? 13 | option(BUILD_C_API "Build C API?" OFF) 14 | 15 | # Confgiure everything 16 | add_subdirectory(configure) 17 | 18 | # Deal with the dependencies 19 | find_package(BLAS) 20 | find_package(LAPACK) 21 | add_subdirectory(dependencies) 22 | 23 | if (NOT BLAS_FOUND OR NOT LAPACK_FOUND) 24 | message(STATUS "BLAS/LAPACK could not be found. A reference version will be employed.") 25 | include(FetchContent) 26 | FetchContent_Declare( 27 | lapack 28 | GIT_REPOSITORY "https://github.com/Reference-LAPACK/lapack" 29 | ) 30 | FetchContent_MakeAvailable(lapack) 31 | set(BLAS_LIBRARIES blas) 32 | set(LAPACK_LIBRARIES lapack) 33 | endif() 34 | 35 | # Source 36 | add_subdirectory(src) 37 | add_fortran_library( 38 | ${PROJECT_NAME} 39 | ${PROJECT_INCLUDE_DIR} 40 | ${CMAKE_INSTALL_INCLUDEDIR} 41 | ${PROJECT_VERSION} 42 | ${PROJECT_VERSION_MAJOR} 43 | ${LINALG_SOURCES} 44 | ) 45 | target_link_libraries( 46 | ${PROJECT_NAME} 47 | ${BLAS_LIBRARIES} 48 | ${LAPACK_LIBRARIES} 49 | ) 50 | link_library(${PROJECT_NAME} ${ferror_LIBRARY} ${ferror_INCLUDE_DIR}) 51 | 52 | # Testing 53 | option(BUILD_TESTING "Build tests") 54 | include(CTest) 55 | message(STATUS "Build tests: ${BUILD_TESTING}") 56 | if (BUILD_TESTING) 57 | enable_testing() 58 | add_subdirectory(tests) 59 | add_subdirectory(tests_c) 60 | endif() 61 | 62 | # Examples 63 | option(BUILD_LINALG_EXAMPLES "Build LINALG examples") 64 | message(STATUS "Build LINALG examples: ${BUILD_LINALG_EXAMPLES}") 65 | if (BUILD_LINALG_EXAMPLES) 66 | add_subdirectory(examples) 67 | endif() -------------------------------------------------------------------------------- /cmake/helper.cmake: -------------------------------------------------------------------------------- 1 | # helper.cmake 2 | # 3 | # A collection of macros and functions making life with CMake and Fortran a 4 | # bit simpler. 5 | 6 | # Use to include and export headers 7 | function(include_headers lib dir install_dir) 8 | target_include_directories( 9 | ${lib} 10 | INTERFACE 11 | $ 12 | $ 13 | ) 14 | endfunction() 15 | 16 | # Use instead of add_library. 17 | function(add_fortran_library lib_name mod_dir include_install_dir version major) 18 | add_library(${lib_name} ${ARGN}) 19 | set_target_properties( 20 | ${lib_name} 21 | PROPERTIES 22 | POSITION_INDEPENDENT_CODE TRUE 23 | OUTPUT_NAME ${lib_name} 24 | VERSION ${version} 25 | SOVERSION ${major} 26 | Fortran_MODULE_DIRECTORY ${include_install_dir} 27 | ) 28 | target_include_directories( 29 | ${lib_name} 30 | PUBLIC 31 | $ 32 | $ 33 | ) 34 | endfunction() 35 | 36 | # Installs the library 37 | function(install_library lib_name lib_install_dir bin_install_dir mod_dir install_dir) 38 | install( 39 | TARGETS ${lib_name} 40 | EXPORT ${lib_name}Targets 41 | RUNTIME DESTINATION ${bin_install_dir} 42 | LIBRARY DESTINATION ${lib_install_dir} 43 | ARCHIVE DESTINATION ${lib_install_dir} 44 | INCLUDES DESTINATION ${install_dir}/include 45 | ) 46 | install( 47 | DIRECTORY ${mod_dir} 48 | DESTINATION ${install_dir} 49 | ) 50 | endfunction() 51 | 52 | # Install the documentation files 53 | function(install_documentation doc_dir install_dir) 54 | install( 55 | DIRECTORY ${doc_dir} 56 | DESTINATION ${install_dir} 57 | ) 58 | endfunction() 59 | 60 | # Links the supplied library 61 | function(link_library targ lib include_dir) 62 | target_link_libraries(${targ} ${lib}) 63 | target_include_directories(${targ} PUBLIC $) 64 | endfunction() 65 | 66 | # ------------------------------------------------------------------------------ 67 | # Helpful Macros 68 | macro(print_all_variables) 69 | message(STATUS "---------- CURRENTLY DEFINED VARIABLES -----------") 70 | get_cmake_property(varNames VARIABLES) 71 | foreach(varName ${varNames}) 72 | message(STATUS ${varName} = ${${varName}}) 73 | endforeach() 74 | message(STATUS "---------- END ----------") 75 | endmacro() -------------------------------------------------------------------------------- /configure/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Get the macros and functions we'll need 2 | include("${PROJECT_SOURCE_DIR}/cmake/helper.cmake") 3 | 4 | # Set a default build type if none was specified 5 | if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) 6 | message(STATUS "Setting build type to 'Release' as none was specified.") 7 | set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) 8 | # Set the possible values of build type for cmake-gui 9 | set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release") 10 | endif() 11 | 12 | # By default, static library 13 | option(BUILD_SHARED_LIBS "Build shared libraries" OFF) 14 | 15 | # Export all symbols on Windows when building libraries 16 | set(CMAKE_WINDOWS_EXPORT_ALL_SYMBOLS TRUE) 17 | 18 | # Utilize the GNU installation structure 19 | include(GNUInstallDirs) 20 | 21 | # Locate the local include directory 22 | set(PROJECT_INCLUDE_DIR ${PROJECT_BINARY_DIR}/include) 23 | set(PROJECT_INCLUDE_DIR ${PROJECT_INCLUDE_DIR} PARENT_SCOPE) -------------------------------------------------------------------------------- /dependencies/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Get FERROR 2 | add_subdirectory(ferror) 3 | set(ferror_LIBRARY ${ferror_LIBRARY} PARENT_SCOPE) 4 | set(ferror_INCLUDE_DIR ${ferror_INCLUDE_DIR} PARENT_SCOPE) 5 | -------------------------------------------------------------------------------- /dependencies/ferror/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | include(FetchContent) 2 | 3 | # Fetch the proper content 4 | FetchContent_Declare( 5 | ferror 6 | GIT_REPOSITORY "https://github.com/jchristopherson/ferror" 7 | ) 8 | FetchContent_MakeAvailable(ferror) 9 | 10 | set(ferror_INCLUDE_DIR ${ferror_BINARY_DIR}/include) 11 | configure_file( 12 | "${ferror_SOURCE_DIR}/include/ferror.h" 13 | "${ferror_INCLUDE_DIR}/ferror.h" 14 | COPYONLY 15 | ) 16 | set(ferror_LIBRARY ferror) 17 | set(ferror_INCLUDE_DIR ${ferror_INCLUDE_DIR} PARENT_SCOPE) 18 | set(ferror_LIBRARY ${ferror_LIBRARY} PARENT_SCOPE) 19 | -------------------------------------------------------------------------------- /doc/favicon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/favicon.png -------------------------------------------------------------------------------- /doc/fonts/FontAwesome.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/FontAwesome.otf -------------------------------------------------------------------------------- /doc/fonts/fontawesome-webfont.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/fontawesome-webfont.eot -------------------------------------------------------------------------------- /doc/fonts/fontawesome-webfont.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/fontawesome-webfont.ttf -------------------------------------------------------------------------------- /doc/fonts/fontawesome-webfont.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/fontawesome-webfont.woff -------------------------------------------------------------------------------- /doc/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /doc/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /doc/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /doc/js/MathJax-config/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/js/MathJax-config/.gitignore -------------------------------------------------------------------------------- /doc/src/linalg.f90: -------------------------------------------------------------------------------- 1 | ! linalg.f90 2 | 3 | module linalg 4 | use linalg_sparse 5 | use linalg_basic 6 | use linalg_sorting 7 | use linalg_eigen 8 | use linalg_lu 9 | use linalg_rz 10 | use linalg_qr 11 | use linalg_tri 12 | use linalg_cholesky 13 | use linalg_lq 14 | use linalg_svd 15 | use linalg_inverse 16 | use linalg_least_squares 17 | implicit none 18 | private 19 | 20 | ! LINALG_BASIC.F90 21 | public :: LA_NO_OPERATION 22 | public :: LA_TRANSPOSE 23 | public :: LA_HERMITIAN_TRANSPOSE 24 | public :: mtx_mult 25 | public :: rank1_update 26 | public :: diag_mtx_mult 27 | public :: trace 28 | public :: mtx_rank 29 | public :: det 30 | public :: swap 31 | public :: recip_mult_array 32 | public :: tri_mtx_mult 33 | public :: band_mtx_mult 34 | public :: band_mtx_to_full_mtx 35 | public :: band_diag_mtx_mult 36 | public :: banded_to_dense 37 | public :: dense_to_banded 38 | public :: extract_diagonal 39 | 40 | ! LINALG_SPARSE.F90 41 | public :: csr_matrix 42 | public :: msr_matrix 43 | public :: size 44 | public :: create_empty_csr_matrix 45 | public :: create_empty_msr_matrix 46 | public :: nonzero_count 47 | public :: dense_to_csr 48 | public :: diag_to_csr 49 | public :: banded_to_csr 50 | public :: csr_to_dense 51 | public :: csr_to_msr 52 | public :: msr_to_csr 53 | public :: dense_to_msr 54 | public :: msr_to_dense 55 | public :: create_csr_matrix 56 | public :: matmul 57 | public :: operator(+) 58 | public :: operator(-) 59 | public :: operator(*) 60 | public :: operator(/) 61 | public :: assignment(=) 62 | public :: transpose 63 | public :: sparse_direct_solve 64 | public :: pgmres_solver 65 | 66 | ! LINALG_SORTING.F90 67 | public :: sort 68 | 69 | ! LINALG_EIGEN.F90 70 | public :: eigen 71 | 72 | ! LINALG_LU.F90 73 | public :: lu_factor 74 | public :: form_lu 75 | public :: solve_lu 76 | 77 | ! LINALG_RZ.F90 78 | public :: rz_factor 79 | public :: mult_rz 80 | 81 | ! LINALG_QR.F90 82 | public :: qr_factor 83 | public :: form_qr 84 | public :: mult_qr 85 | public :: qr_rank1_update 86 | public :: solve_qr 87 | 88 | ! LINALG_TRI.F90 89 | public :: solve_triangular_system 90 | 91 | ! LINALG_CHOLESKY.F90 92 | public :: cholesky_factor 93 | public :: cholesky_rank1_update 94 | public :: cholesky_rank1_downdate 95 | public :: solve_cholesky 96 | 97 | ! LINALG_LQ.F90 98 | public :: lq_factor 99 | public :: form_lq 100 | public :: mult_lq 101 | public :: solve_lq 102 | 103 | ! LINALG_SVD.F90 104 | public :: svd 105 | 106 | ! LINALG_INVERSE.F90 107 | public :: mtx_inverse 108 | public :: mtx_pinverse 109 | 110 | ! LINALG_LEAST_SQUARES.F90 111 | public :: solve_least_squares 112 | public :: solve_least_squares_full 113 | public :: solve_least_squares_svd 114 | 115 | end module 116 | -------------------------------------------------------------------------------- /doc/tipuesearch/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/tipuesearch/.DS_Store -------------------------------------------------------------------------------- /doc/tipuesearch/img/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/tipuesearch/img/.DS_Store -------------------------------------------------------------------------------- /doc/tipuesearch/img/loader.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/tipuesearch/img/loader.gif -------------------------------------------------------------------------------- /doc/tipuesearch/img/search.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/doc/tipuesearch/img/search.png -------------------------------------------------------------------------------- /doc/tipuesearch/tipuesearch_set.js: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | Tipue Search 4.0 4 | Copyright (c) 2014 Tipue 5 | Tipue Search is released under the MIT License 6 | http://www.tipue.com/search 7 | */ 8 | 9 | 10 | var tipuesearch_stop_words = ["and", "be", "by", "do", "for", "he", "how", "if", "is", "it", "my", "not", "of", "or", "the", "to", "up", "what", "when", "use", "who", "she", "my", "his", "her"]; 11 | 12 | var tipuesearch_replace = {"words": [ 13 | {"word": "tipua", "replace_with": "tipue"}, 14 | {"word": "javscript", "replace_with": "javascript"} 15 | ]}; 16 | 17 | var tipuesearch_stem = {"words": [ 18 | {"word": "e-mail", "stem": "email"}, 19 | {"word": "javascript", "stem": "script"}, 20 | {"word": "procedure", "stem": "subroutine"}, 21 | {"word": "procedure", "stem": "function"} 22 | ]}; 23 | 24 | -------------------------------------------------------------------------------- /docs.md: -------------------------------------------------------------------------------- 1 | --- 2 | project: LINALG 3 | summary: LINALG is a linear algebra library that provides a user-friendly interface to several BLAS and LAPACK routines. 4 | project_github: https://github.com/jchristopherson/linalg 5 | author: Jason Christopherson 6 | author_email: jchristopherson@hotmail.com 7 | src_dir: ./src 8 | exclude_dir: **/qrupdate 9 | exclude_dir: **/sparskit2 10 | exclude: **/blas.f90 11 | exclude: **/lapack.f90 12 | exclude: **/qrupdate.f90 13 | exclude: **/sparskit.f90 14 | exclude: **/linalg_c_api.f90 15 | output_dir: ./doc 16 | display: public 17 | source: true 18 | proc_internals: true 19 | sort: permission-alpha 20 | print_creation_date: true 21 | creation_date: %Y-%m-%d %H:%M %z 22 | --- -------------------------------------------------------------------------------- /examples/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # LU Example 2 | add_executable(lu_example linalg_lu_example.f90) 3 | target_link_libraries(lu_example linalg) 4 | 5 | # QR Example 6 | add_executable(qr_example linalg_qr_example.f90) 7 | target_link_libraries(qr_example linalg) 8 | 9 | # Overdetermined Example 10 | add_executable(od_example linalg_od_example.f90) 11 | target_link_libraries(od_example linalg) 12 | 13 | # Eigen Example 14 | add_executable(eigen_example linalg_eigen_example.f90) 15 | target_link_libraries(eigen_example linalg) 16 | 17 | # LU Example - Full Method 18 | add_executable(lu_full_example linalg_lu_full_example.f90) 19 | target_link_libraries(lu_full_example linalg) 20 | 21 | # QR Example - Full Method, No Pivoting 22 | add_executable(qr_full_example linalg_qr_full_example.f90) 23 | target_link_libraries(qr_full_example linalg) 24 | 25 | # QR Example - QR Multiplication Example, No Pivoting 26 | add_executable(qr_mult_example linalg_qr_mult_example.f90) 27 | target_link_libraries(qr_mult_example linalg) 28 | 29 | # QR Update Example 30 | add_executable(qr_update_example linalg_qr_update_example.f90) 31 | target_link_libraries(qr_update_example linalg) 32 | 33 | # Cholesky Example 34 | add_executable(cholesky_example linalg_cholesky_example.f90) 35 | target_link_libraries(cholesky_example linalg) 36 | 37 | # Cholesky Update Example 38 | add_executable(cholesky_update_example linalg_cholesky_update_example.f90) 39 | target_link_libraries(cholesky_update_example linalg) 40 | 41 | # Cholesky Downdate Example 42 | add_executable(cholesky_downdate_example linalg_cholesky_downdate_example.f90) 43 | target_link_libraries(cholesky_downdate_example linalg) 44 | 45 | # Matrix Inverse Example 46 | add_executable(inverse_example linalg_inverse_example.f90) 47 | target_link_libraries(inverse_example linalg) 48 | 49 | # Moore-Penrose Example 50 | add_executable(pinverse_example linalg_pinverse_example.f90) 51 | target_link_libraries(pinverse_example linalg) 52 | 53 | # SVD Example 54 | add_executable(svd_example linalg_svd_example.f90) 55 | target_link_libraries(svd_example linalg) 56 | 57 | # Full LQ Example 58 | add_executable(lq_full_example linalg_lq_full_example.f90) 59 | target_link_libraries(lq_full_example linalg) 60 | 61 | # LQ Multiplication Example 62 | add_executable(lq_mult_example linalg_lq_mult_example.f90) 63 | target_link_libraries(lq_mult_example linalg) 64 | 65 | # LQ Example 66 | add_executable(lq_example linalg_lq_example.f90) 67 | target_link_libraries(lq_example linalg) 68 | 69 | # Sparse Direct Solve Example 70 | add_executable(sparse_direct_example linalg_sparse_direct_example.f90) 71 | target_link_libraries(sparse_direct_example linalg) 72 | 73 | # -------------------- 74 | # C API Eigenvalue Example 75 | if (${BUILD_C_API}) 76 | include_directories(${PROJECT_SOURCE_DIR}/include) 77 | add_executable(c_eigen_example c_linalg_eigen_example.c) 78 | target_link_libraries(c_eigen_example linalg) 79 | 80 | add_executable(c_lu_example c_linalg_lu_example.c) 81 | target_link_libraries(c_lu_example linalg) 82 | endif() -------------------------------------------------------------------------------- /examples/c_linalg_lu_example.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "linalg.h" 4 | 5 | #define INDEX(i, j, m) ((j) * (m) + (i)) 6 | 7 | int main() { 8 | // Local Variables 9 | int i, flag, pvt[3]; 10 | 11 | // Build the 3-by-3 matrix A - Use column-major formating! 12 | // | 1 2 3 | 13 | // A = | 4 5 6 | 14 | // | 7 8 0 | 15 | double a[] = {1.0, 4.0, 7.0, 2.0, 5.0, 8.0, 3.0, 6.0, 0.0}; 16 | 17 | // Build the right-hand-side vector B. 18 | // | -1 | 19 | // b = | -2 | 20 | // | -3 | 21 | double b[] = {-1.0, -2.0, -3.0}; 22 | 23 | // The solution is: 24 | // | 1/3 | 25 | // x = | -2/3 | 26 | // | 0 | 27 | 28 | // Compute the LU factorization 29 | flag = la_lu_factor(3, 3, a, 3, pvt); 30 | if (flag != LA_NO_ERROR) return flag; 31 | 32 | // Solve. The results overwrite b. 33 | flag = la_solve_lu(3, 1, a, 3, pvt, b, 3); 34 | if (flag != LA_NO_ERROR) return flag; 35 | 36 | // Display the results 37 | printf("LU Solution: X = \n"); 38 | for (i = 0; i < 3; i++) { 39 | printf("%8.4f\n", b[i]); 40 | } 41 | 42 | // End 43 | return 0; 44 | } -------------------------------------------------------------------------------- /examples/linalg_cholesky_downdate_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_cholesky_downdate_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), u(3), ad(3,3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 4.25 11.25 -15 | 14 | ! A = | 11.25 39.25 -46 | 15 | ! | -15 -46 102 | 16 | a = reshape([4.25d0, 11.25d0, -15.0d0, 11.25d0, 39.25d0, -46.0d0, & 17 | -15.0d0, -46.0d0, 102.0d0], [3, 3]) 18 | 19 | ! The downdate vector 20 | ! | 0.5 | 21 | ! u = | -1.5 | 22 | ! | 2 | 23 | u = [0.5d0, -1.5d0, 2.0d0] 24 | 25 | ! Compute the rank 1 downdate of A 26 | ad = a 27 | call rank1_update(-1.0d0, u, u, ad) 28 | 29 | ! Compute the Cholesky factorization of the original matrix 30 | call cholesky_factor(a) 31 | 32 | ! Apply the rank 1 downdate to the factored matrix 33 | call cholesky_rank1_downdate(a, u) 34 | 35 | ! Compute the Cholesky factorization of the downdate to the original matrix 36 | call cholesky_factor(ad) 37 | 38 | ! Display the matrices 39 | print '(A)', "Downdating the Factored Form:" 40 | do i = 1, size(a, 1) 41 | print *, a(i,:) 42 | end do 43 | 44 | print '(A)', "Downdating A Directly:" 45 | do i = 1, size(ad, 1) 46 | print *, ad(i,:) 47 | end do 48 | end program -------------------------------------------------------------------------------- /examples/linalg_cholesky_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_cholesky_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3, 3), b(3), bu(3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 positive-definite matrix A. 13 | ! | 4 12 -16 | 14 | ! A = | 12 37 -43 | 15 | ! |-16 -43 98 | 16 | a = reshape([4.0d0, 12.0d0, -16.0d0, 12.0d0, 37.0d0, -43.0d0, -16.0d0, & 17 | -43.0d0, 98.0d0], [3, 3]) 18 | 19 | ! Build the 3-element array B 20 | ! | 5 | 21 | ! b = | 1 | 22 | ! | 3 | 23 | b = [5.0d0, 1.0d0, 3.0d0] 24 | 25 | ! Make a copy of B for later use - not necessary, but just for example to 26 | ! illustrate the long or manual method of solving a Cholesky factored system 27 | bu = b 28 | 29 | ! Compute the Cholesky factorization of A considering only the upper 30 | ! triangular portion of A (the default configuration). 31 | call cholesky_factor(a) 32 | 33 | ! Compute the solution 34 | call solve_cholesky(.true., a, b) 35 | 36 | ! Display the results 37 | print '(A)', "Cholesky Solution: X = " 38 | print '(F8.4)', (b(i), i = 1, size(b)) 39 | 40 | ! The solution could also be computed manually noting the Cholesky 41 | ! factorization causes A = R**T * R. Then R**T * R * X = B. 42 | 43 | ! Step 1 would then be to solve the problem R**T * Y = B, for Y. 44 | call solve_triangular_system(.true., .true., .true., a, bu) 45 | 46 | ! Now, solve the problem R * X = Y, for X 47 | call solve_triangular_system(.true., .false., .true., a, bu) 48 | 49 | ! Display the results 50 | print '(A)', "Cholesky Solution (Manual Approach): X = " 51 | print '(F8.4)', (bu(i), i = 1, size(bu)) 52 | end program -------------------------------------------------------------------------------- /examples/linalg_cholesky_update_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_cholesky_update_example 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), u(3), au(3,3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 positive-definite matrix A. 13 | ! | 4 12 -16 | 14 | ! A = | 12 37 -43 | 15 | ! |-16 -43 98 | 16 | a = reshape([4.0d0, 12.0d0, -16.0d0, 12.0d0, 37.0d0, -43.0d0, -16.0d0, & 17 | -43.0d0, 98.0d0], [3, 3]) 18 | 19 | ! Build the update vector U 20 | u = [0.5d0, -1.5d0, 2.0d0] 21 | 22 | ! Compute the rank 1 update of A 23 | au = a 24 | call rank1_update(1.0d0, u, u, au) 25 | 26 | ! Compute the Cholesky factorization of the original matrix 27 | call cholesky_factor(a) 28 | 29 | ! Apply the rank 1 update to the factored matrix 30 | call cholesky_rank1_update(a, u) 31 | 32 | ! Compute the Cholesky factorization of the update of the original matrix 33 | call cholesky_factor(au) 34 | 35 | ! Display the matrices 36 | print '(A)', "Updating the Factored Form:" 37 | do i = 1, size(a, 1) 38 | print *, a(i,:) 39 | end do 40 | 41 | print '(A)', "Updating A Directly:" 42 | do i = 1, size(au, 1) 43 | print *, au(i,:) 44 | end do 45 | end program -------------------------------------------------------------------------------- /examples/linalg_eigen_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_eigen_example.f90 2 | 3 | ! This is an example illustrating the use of the eigenvalue and eigenvector 4 | ! routines to solve a free vibration problem of 3 masses connected by springs. 5 | ! 6 | ! k1 k2 k3 k4 7 | ! |-\/\/\-| m1 |-\/\/\-| m2 |-\/\/\-| m3 |-\/\/\-| 8 | ! 9 | ! As illustrated above, the system consists of 3 masses connected by springs. 10 | ! Spring k1 and spring k4 connect the end masses to ground. The equations of 11 | ! motion for this system are as follows. 12 | ! 13 | ! | m1 0 0 | |x1"| | k1+k2 -k2 0 | |x1| |0| 14 | ! | 0 m2 0 | |x2"| + | -k2 k2+k3 -k3 | |x2| = |0| 15 | ! | 0 0 m3| |x3"| | 0 -k3 k3+k4| |x3| |0| 16 | ! 17 | ! Notice: x1" = the second time derivative of x1. 18 | program example 19 | use iso_fortran_env, only : real64, int32 20 | use linalg 21 | implicit none 22 | 23 | ! Define the model parameters 24 | real(real64), parameter :: pi = 3.14159265359d0 25 | real(real64), parameter :: m1 = 0.5d0 26 | real(real64), parameter :: m2 = 2.5d0 27 | real(real64), parameter :: m3 = 0.75d0 28 | real(real64), parameter :: k1 = 5.0d6 29 | real(real64), parameter :: k2 = 10.0d6 30 | real(real64), parameter :: k3 = 10.0d6 31 | real(real64), parameter :: k4 = 5.0d6 32 | 33 | ! Local Variables 34 | integer(int32) :: i, j 35 | real(real64) :: m(3,3), k(3,3), natFreq(3) 36 | complex(real64) :: vals(3), modeShapes(3,3) 37 | 38 | ! Define the mass matrix 39 | m = reshape([m1, 0.0d0, 0.0d0, 0.0d0, m2, 0.0d0, 0.0d0, 0.0d0, m3], [3, 3]) 40 | 41 | ! Define the stiffness matrix 42 | k = reshape([k1 + k2, -k2, 0.0d0, -k2, k2 + k3, -k3, 0.0d0, -k3, k3 + k4], & 43 | [3, 3]) 44 | 45 | ! Compute the eigenvalues and eigenvectors. 46 | call eigen(k, m, vals, vecs = modeShapes) 47 | 48 | ! Sort the eigenvalues and eigenvectors 49 | call sort(vals, modeShapes) 50 | 51 | ! Compute the natural frequency values, and return them with units of Hz. 52 | ! Notice, all eigenvalues and eigenvectors are real for this example. 53 | natFreq = sqrt(real(vals)) / (2.0d0 * pi) 54 | 55 | ! Display the natural frequency and mode shape values. 56 | print '(A)', "Modal Information:" 57 | do i = 1, size(natFreq) 58 | print '(AI0AF8.4A)', "Mode ", i, ": (", natFreq(i), " Hz)" 59 | print '(F10.3)', (real(modeShapes(j,i)), j = 1, size(natFreq)) 60 | end do 61 | end program -------------------------------------------------------------------------------- /examples/linalg_inverse_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_inverse_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), ai(3,3), c(3,3) 10 | integer(int32) :: i 11 | 12 | ! Construct the 3-by-3 matrix A to invert 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape([1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, & 17 | 0.0d0], [3, 3]) 18 | 19 | ! Compute the inverse of A. Notice, the original matrix is overwritten 20 | ! with it's inverse. 21 | ai = a 22 | call mtx_inverse(ai) 23 | 24 | ! Show that A * inv(A) = I 25 | c = matmul(a, ai) 26 | 27 | ! Display the inverse 28 | print '(A)', "Inverse:" 29 | do i = 1, size(ai, 1) 30 | print *, ai(i,:) 31 | end do 32 | 33 | ! Display the result of A * inv(A) 34 | print '(A)', "A * A**-1:" 35 | do i = 1, size(c, 1) 36 | print *, c(i,:) 37 | end do 38 | end program -------------------------------------------------------------------------------- /examples/linalg_lq_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_lq_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Local Variables 9 | real(real64) :: a(3,3), tau(3), b(3) 10 | integer(int32) :: i, pvt(3) 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the right-hand-side vector B. 21 | ! | -1 | 22 | ! b = | -2 | 23 | ! | -3 | 24 | b = [-1.0d0, -2.0d0, -3.0d0] 25 | 26 | ! The solution is: 27 | ! | 1/3 | 28 | ! x = | -2/3 | 29 | ! | 0 | 30 | 31 | ! Compute the LQ factorization 32 | call lq_factor(a, tau) 33 | 34 | ! Compute the solution. The results overwrite b. 35 | call solve_lq(a, tau, b) 36 | 37 | ! Display the results 38 | print '(A)', "LQ Solution: X = " 39 | print '(F8.4)', (b(i), i = 1, size(b)) 40 | end program -------------------------------------------------------------------------------- /examples/linalg_lq_full_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_lq_full_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), b(3), q(3,3), tau(3), x(3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the right-hand-side vector B. 21 | ! | -1 | 22 | ! b = | -2 | 23 | ! | -3 | 24 | b = [-1.0d0, -2.0d0, -3.0d0] 25 | 26 | ! The solution is: 27 | ! | 1/3 | 28 | ! x = | -2/3 | 29 | ! | 0 | 30 | 31 | ! Compute the LQ factorization 32 | call lq_factor(a, tau) 33 | 34 | ! Build L and Q. A is overwritten with L 35 | call form_lq(a, tau, q) 36 | 37 | ! Solve the lower triangular problem and store the solution in B. 38 | ! 39 | ! A comment about this solution noting we've factored A = L * Q. 40 | ! 41 | ! We then have to solve: L * Q * X = B for X. If we let Y = Q * X, then 42 | ! we solve the lower triangular system L * Y = B for Y. 43 | call solve_triangular_system(.false., .false., .true., a, b) 44 | 45 | ! Now we've solved the lower triangular system L * Y = B for Y. At 46 | ! this point we solve the problem: Q * X = Y. Q is an orthogonal matrix; 47 | ! therefore, inv(Q) = Q**T. We can solve this by multiplying both 48 | ! sides by Q**T: 49 | ! 50 | ! Compute Q**T * B = X 51 | call mtx_mult(.true., 1.0d0, q, b, 0.0d0, x) 52 | 53 | ! Display the results 54 | print '(A)', "LQ Solution: X = " 55 | print '(F8.4)', (x(i), i = 1, size(x)) 56 | end program -------------------------------------------------------------------------------- /examples/linalg_lq_mult_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_qr_mult_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Local Variables 9 | real(real64) :: a(3,3), tau(3), b(3) 10 | integer(int32) :: i, pvt(3) 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the right-hand-side vector B. 21 | ! | -1 | 22 | ! b = | -2 | 23 | ! | -3 | 24 | b = [-1.0d0, -2.0d0, -3.0d0] 25 | 26 | ! The solution is: 27 | ! | 1/3 | 28 | ! x = | -2/3 | 29 | ! | 0 | 30 | 31 | ! Compute the LQ factorization 32 | call lq_factor(a, tau) 33 | 34 | ! Solve the lower triangular problem and store the solution in B. 35 | ! 36 | ! A comment about this solution noting we've factored A = L * Q. 37 | ! 38 | ! We then have to solve: L * Q * X = B for X. If we let Y = Q * X, then 39 | ! we solve the lower triangular system L * Y = B for Y. 40 | call solve_triangular_system(.false., .false., .true., a, b) 41 | 42 | ! Now we've solved the lower triangular system L * Y = B for Y. At 43 | ! this point we solve the problem: Q * X = Y. Q is an orthogonal matrix; 44 | ! therefore, inv(Q) = Q**T. We can solve this by multiplying both 45 | ! sides by Q**T: 46 | ! 47 | ! Compute Q**T * B = X 48 | call mult_lq(.true., a, tau, b) 49 | 50 | ! Display the results 51 | print '(A)', "LQ Solution: X = " 52 | print '(F8.4)', (b(i), i = 1, size(b)) 53 | end program -------------------------------------------------------------------------------- /examples/linalg_lu_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_lu_example.f90 2 | 3 | ! Example Source: 4 | ! https://www.mathworks.com/help/matlab/ref/lu.html?s_tid=srchtitle 5 | program example 6 | use iso_fortran_env, only : real64, int32 7 | use linalg 8 | implicit none 9 | 10 | ! Local Variables 11 | real(real64) :: a(3,3), b(3) 12 | integer(int32) :: i, pvt(3) 13 | 14 | ! Build the 3-by-3 matrix A. 15 | ! | 1 2 3 | 16 | ! A = | 4 5 6 | 17 | ! | 7 8 0 | 18 | a = reshape( & 19 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 20 | [3, 3]) 21 | 22 | ! Build the right-hand-side vector B. 23 | ! | -1 | 24 | ! b = | -2 | 25 | ! | -3 | 26 | b = [-1.0d0, -2.0d0, -3.0d0] 27 | 28 | ! The solution is: 29 | ! | 1/3 | 30 | ! x = | -2/3 | 31 | ! | 0 | 32 | 33 | ! Compute the LU factorization 34 | call lu_factor(a, pvt) 35 | 36 | ! Compute the solution. The results overwrite b. 37 | call solve_lu(a, pvt, b) 38 | 39 | ! Display the results. 40 | print '(A)', "LU Solution: X = " 41 | print '(F8.4)', (b(i), i = 1, size(b)) 42 | end program -------------------------------------------------------------------------------- /examples/linalg_lu_full_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_lu_full_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), b(3), u(3,3), p(3,3) 10 | integer(int32) :: i, pvt(3) 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the right-hand-side vector B. 21 | ! | -1 | 22 | ! b = | -2 | 23 | ! | -3 | 24 | b = [-1.0d0, -2.0d0, -3.0d0] 25 | 26 | ! The solution is: 27 | ! | 1/3 | 28 | ! x = | -2/3 | 29 | ! | 0 | 30 | 31 | ! Compute the LU factorization 32 | call lu_factor(a, pvt) 33 | 34 | ! Extract the L and U matrices. A is overwritten with L. 35 | call form_lu(a, pvt, u, p) 36 | 37 | ! Solve the lower triangular system L * Y = P * B for Y, but first compute 38 | ! P * B, and store the results in B 39 | b = matmul(p, b) 40 | 41 | ! Now, compute the solution to the lower triangular system. Store the 42 | ! result in B. Remember, L is unit diagonal (ones on its diagonal) 43 | call solve_triangular_system(.false., .false., .false., a, b) 44 | 45 | ! Solve the upper triangular system U * X = Y for X. 46 | call solve_triangular_system(.true., .false., .true., u, b) 47 | 48 | ! Display the results. 49 | print '(A)', "LU Solution: X = " 50 | print '(F8.4)', (b(i), i = 1, size(b)) 51 | end program 52 | -------------------------------------------------------------------------------- /examples/linalg_od_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_od_example.f90 2 | 3 | ! Example Source: https://en.wikipedia.org/wiki/Overdetermined_system 4 | program example 5 | use iso_fortran_env, only : real64, int32 6 | use linalg 7 | implicit none 8 | 9 | ! Local Variables 10 | real(real64) :: a(3,2), b(3) 11 | integer(int32) :: i 12 | 13 | ! Build the 3-by-2 matrix A 14 | ! | 2 1 | 15 | ! A = |-3 1 | 16 | ! |-1 1 | 17 | a = reshape([2.0d0, -3.0d0, -1.0d0, 1.0d0, 1.0d0, 1.0d0], [3, 2]) 18 | 19 | ! Build the right-hand-side vector B. 20 | ! |-1 | 21 | ! b = |-2 | 22 | ! | 1 | 23 | b = [-1.0d0, -2.0d0, 1.0d0] 24 | 25 | ! The solution is: 26 | ! x = [0.13158, -0.57895]**T 27 | 28 | ! Compute the solution via a least-squares approach. The results overwrite 29 | ! the first 2 elements in b. 30 | call solve_least_squares_svd(a, b) 31 | 32 | ! Display the results 33 | print '(A)', "Least Squares Solution: X = " 34 | print '(F9.5)', (b(i), i = 1, size(a, 2)) 35 | end program -------------------------------------------------------------------------------- /examples/linalg_pinverse_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_pinverse_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : int32, real64 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,2), ai(2,3), ao(3,2), c(2,2) 10 | integer(int32) :: i 11 | 12 | ! Create the 3-by-2 matrix A 13 | ! | 1 0 | 14 | ! A = | 0 1 | 15 | ! | 0 1 | 16 | a = reshape([1.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0], [3, 2]) 17 | ao = a ! Just making a copy for later as mtx_pinverse will destroy the 18 | ! contents of the original matrix 19 | 20 | ! The Moore-Penrose pseudo-inverse of this matrix is: 21 | ! | 1 0 0 | 22 | ! A**-1 = | | 23 | ! | 0 1/2 1/2 | 24 | call mtx_pinverse(a, ai) 25 | 26 | ! Notice, A**-1 * A is an identity matrix. 27 | c = matmul(ai, ao) 28 | 29 | ! Display the inverse 30 | print '(A)', "Inverse:" 31 | do i = 1, size(ai, 1) 32 | print *, ai(i,:) 33 | end do 34 | 35 | ! Display the result of inv(A) * A 36 | print '(A)', "A**-1 * A:" 37 | do i = 1, size(c, 1) 38 | print *, c(i,:) 39 | end do 40 | end program -------------------------------------------------------------------------------- /examples/linalg_qr_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_qr_example.f90 2 | 3 | ! Example Source: 4 | ! https://www.mathworks.com/help/matlab/ref/lu.html?s_tid=srchtitle 5 | ! 6 | ! This is a repeat of the LU factorization example, but using QR factorization 7 | ! instead. 8 | program example 9 | use iso_fortran_env, only : real64, int32 10 | use linalg 11 | implicit none 12 | 13 | ! Local Variables 14 | real(real64) :: a(3,3), tau(3), b(3) 15 | integer(int32) :: i, pvt(3) 16 | 17 | ! Build the 3-by-3 matrix A. 18 | ! | 1 2 3 | 19 | ! A = | 4 5 6 | 20 | ! | 7 8 0 | 21 | a = reshape( & 22 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 23 | [3, 3]) 24 | 25 | ! Build the right-hand-side vector B. 26 | ! | -1 | 27 | ! b = | -2 | 28 | ! | -3 | 29 | b = [-1.0d0, -2.0d0, -3.0d0] 30 | 31 | ! The solution is: 32 | ! | 1/3 | 33 | ! x = | -2/3 | 34 | ! | 0 | 35 | 36 | ! Compute the QR factorization, using pivoting 37 | pvt = 0 ! Zero every entry in order not to lock any column in place 38 | call qr_factor(a, tau, pvt) 39 | 40 | ! Compute the solution. The results overwrite b. 41 | call solve_qr(a, tau, pvt, b) 42 | 43 | ! Display the results. 44 | print '(A)', "QR Solution: X = " 45 | print '(F8.4)', (b(i), i = 1, size(b)) 46 | 47 | ! Notice, QR factorization without pivoting could be accomplished in the 48 | ! same manner. The only difference is to omit the PVT array (column pivot 49 | ! tracking array). 50 | end program -------------------------------------------------------------------------------- /examples/linalg_qr_full_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_qr_full_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), b(3), q(3,3), tau(3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the right-hand-side vector B. 21 | ! | -1 | 22 | ! b = | -2 | 23 | ! | -3 | 24 | b = [-1.0d0, -2.0d0, -3.0d0] 25 | 26 | ! The solution is: 27 | ! | 1/3 | 28 | ! x = | -2/3 | 29 | ! | 0 | 30 | 31 | ! Compute the QR factorization without column pivoting 32 | call qr_factor(a, tau) 33 | 34 | ! Build Q and R. A is overwritten with R 35 | call form_qr(a, tau, q) 36 | 37 | ! As this system is square, matrix R is upper triangular. Also, Q is 38 | ! always orthogonal such that it's inverse and transpose are equal. As the 39 | ! system is now factored, its form is: Q * R * X = B. Solving this system 40 | ! is then as simple as solving the upper triangular system: 41 | ! R * X = Q**T * B. 42 | 43 | ! Compute Q**T * B, and store the results in B 44 | b = matmul(transpose(q), b) 45 | 46 | ! Solve the upper triangular system R * X = Q**T * B for X 47 | call solve_triangular_system(.true., .false., .true., a, b) 48 | 49 | ! Display the results 50 | print '(A)', "QR Solution: X = " 51 | print '(F8.4)', (b(i), i = 1, size(b)) 52 | 53 | ! Notice, QR factorization with column pivoting could be accomplished via 54 | ! a similar approach, but the column pivoting would need to be accounted 55 | ! for by noting that Q * R = A * P, where P is an N-by-N matrix describing 56 | ! the column pivoting operations. 57 | end program 58 | -------------------------------------------------------------------------------- /examples/linalg_qr_mult_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_qr_mult_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : real64, int32 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), b(3), tau(3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the right-hand-side vector B. 21 | ! | -1 | 22 | ! b = | -2 | 23 | ! | -3 | 24 | b = [-1.0d0, -2.0d0, -3.0d0] 25 | 26 | ! The solution is: 27 | ! | 1/3 | 28 | ! x = | -2/3 | 29 | ! | 0 | 30 | 31 | ! Compute the QR factorization without column pivoting 32 | call qr_factor(a, tau) 33 | 34 | ! As this system is square, matrix R is upper triangular. Also, Q is 35 | ! always orthogonal such that it's inverse and transpose are equal. As the 36 | ! system is now factored, its form is: Q * R * X = B. Solving this system 37 | ! is then as simple as solving the upper triangular system: 38 | ! R * X = Q**T * B. 39 | 40 | ! Compute Q**T * B, and store the results in B. Notice, using mult_qr 41 | ! avoids direct construction of the full Q and R matrices. 42 | call mult_qr(.true., a, tau, b) 43 | 44 | ! Solve the upper triangular system R * X = Q**T * B for X 45 | call solve_triangular_system(.true., .false., .true., a, b) 46 | 47 | ! Display the results 48 | print '(A)', "QR Solution: X = " 49 | print '(F8.4)', (b(i), i = 1, size(b)) 50 | 51 | ! Notice, QR factorization with column pivoting could be accomplished via 52 | ! a similar approach, but the column pivoting would need to be accounted 53 | ! for by noting that Q * R = A * P, where P is an N-by-N matrix describing 54 | ! the column pivoting operations. 55 | end program 56 | -------------------------------------------------------------------------------- /examples/linalg_qr_update_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_qr_update_example.f90 2 | 3 | program example 4 | use iso_fortran_env 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,3), u(3), v(3), r(3,3), tau(3), q(3,3), qu(3,3) 10 | integer(int32) :: i 11 | 12 | ! Build the 3-by-3 matrix A. 13 | ! | 1 2 3 | 14 | ! A = | 4 5 6 | 15 | ! | 7 8 0 | 16 | a = reshape( & 17 | [1.0d0, 4.0d0, 7.0d0, 2.0d0, 5.0d0, 8.0d0, 3.0d0, 6.0d0, 0.0d0], & 18 | [3, 3]) 19 | 20 | ! Build the update vectors 21 | ! | 1/2 | | 1 | 22 | ! u = | 3/2 |, v = | 5 | 23 | ! | 3 | | 2 | 24 | u = [0.5d0, 1.5d0, 3.0d0] 25 | v = [1.0d0, 5.0d0, 2.0d0] 26 | 27 | ! Compute the QR factorization of the original matrix 28 | r = a ! Making a copy as the matrix will be overwritten by qr_factor 29 | call qr_factor(r, tau) 30 | 31 | ! Form Q & R 32 | call form_qr(r, tau, q) 33 | 34 | ! Compute the rank 1 update to the original matrix such that: 35 | ! A = A + u * v**T 36 | call rank1_update(1.0d0, u, v, a) 37 | 38 | ! Compute the rank 1 update to the factorization. Notice, the contents 39 | ! of U & V are destroyed as part of this process. 40 | call qr_rank1_update(q, r, u, v) 41 | 42 | ! As comparison, compute the QR factorization of the rank 1 updated matrix 43 | call qr_factor(a, tau) 44 | call form_qr(a, tau, qu) 45 | 46 | ! Display the matrices 47 | print '(A)', "Updating the Factored Form:" 48 | print '(A)', "Q = " 49 | do i = 1, size(q, 1) 50 | print *, q(i,:) 51 | end do 52 | print '(A)', "R = " 53 | do i = 1, size(r, 1) 54 | print *, r(i,:) 55 | end do 56 | 57 | print '(A)', "Updating A Directly:" 58 | print '(A)', "Q = " 59 | do i = 1, size(qu, 1) 60 | print *, qu(i,:) 61 | end do 62 | print '(A)', "R = " 63 | do i = 1, size(a, 1) 64 | print *, a(i,:) 65 | end do 66 | end program -------------------------------------------------------------------------------- /examples/linalg_sparse_direct_example.f90: -------------------------------------------------------------------------------- 1 | program example 2 | use iso_fortran_env 3 | use linalg 4 | implicit none 5 | 6 | ! Local Variables 7 | integer(int32) :: ipiv(4) 8 | real(real64) :: dense(4, 4), b(4), x(4), bc(4) 9 | type(csr_matrix) :: sparse 10 | 11 | ! Build the matrices as dense matrices 12 | dense = reshape([ & 13 | 5.0d0, 0.0d0, 0.0d0, 0.0d0, & 14 | 0.0d0, 8.0d0, 0.0d0, 6.0d0, & 15 | 0.0d0, 0.0d0, 3.0d0, 0.0d0, & 16 | 0.0d0, 0.0d0, 0.0d0, 5.0d0], [4, 4]) 17 | b = [2.0d0, -1.5d0, 8.0d0, 1.0d0] 18 | 19 | ! Convert to sparse (CSR format) 20 | ! Note, the assignment operator is overloaded to allow conversion. 21 | sparse = dense 22 | 23 | ! Compute the solution to the sparse equations 24 | call sparse_direct_solve(sparse, b, x) ! Results stored in x 25 | 26 | ! Print the solution 27 | print "(A)", "Sparse Solution:" 28 | print *, x 29 | 30 | ! Perform a sanity check on the solution 31 | ! Note, matmul is overloaded to allow multiplication with sparse matrices 32 | bc = matmul(sparse, x) 33 | print "(A)", "Computed RHS:" 34 | print *, bc 35 | print "(A)", "Original RHS:" 36 | print *, b 37 | 38 | ! For comparison, solve the dense system via LU decomposition 39 | call lu_factor(dense, ipiv) 40 | call solve_lu(dense, ipiv, b) ! Results stored in b 41 | print "(A)", "Dense Solution:" 42 | print *, b 43 | end program -------------------------------------------------------------------------------- /examples/linalg_svd_example.f90: -------------------------------------------------------------------------------- 1 | ! linalg_svd_example.f90 2 | 3 | program example 4 | use iso_fortran_env, only : int32, real64 5 | use linalg 6 | implicit none 7 | 8 | ! Variables 9 | real(real64) :: a(3,2), s(2), u(3,3), vt(2,2), ac(3,2) 10 | integer(int32) :: i 11 | 12 | ! Initialize the 3-by-2 matrix A 13 | ! | 2 1 | 14 | ! A = |-3 1 | 15 | ! |-1 1 | 16 | a = reshape([2.0d0, -3.0d0, -1.0d0, 1.0d0, 1.0d0, 1.0d0], [3, 2]) 17 | 18 | ! Compute the singular value decomposition of A. Notice, V**T is returned 19 | ! instead of V. Also note, A is overwritten. 20 | call svd(a, s, u, vt) 21 | 22 | ! Display the results 23 | print '(A)', "U =" 24 | do i = 1, size(u, 1) 25 | print *, u(i,:) 26 | end do 27 | 28 | print '(A)', "S =" 29 | print '(F9.5)', (s(i), i = 1, size(a, 2)) 30 | 31 | print '(A)', "V**T =" 32 | do i = 1, size(vt, 1) 33 | print *, vt(i,:) 34 | end do 35 | 36 | ! Compute U * S * V**T, but first establish S in full form 37 | call diag_mtx_mult(.true., 1.0d0, s, vt) ! Compute: VT = S * V**T 38 | ac = matmul(u(:,1:2), vt) 39 | print '(A)', "U * S * V**T =" 40 | do i = 1, size(ac, 1) 41 | print *, ac(i,:) 42 | end do 43 | end program 44 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "linalg" 2 | version = "1.8.3" 3 | license = "GPL-3.0" 4 | author = "Jason Christopherson" 5 | maintainer = "Jason Christopherson" 6 | copyright = "Copyright 2017-2025, Jason Christopherson" 7 | description = "A linear algebra library that provides a user-friendly interface to several BLAS and LAPACK routines." 8 | homepage = "https://github.com/jchristopherson/linalg" 9 | 10 | [library] 11 | source-dir = "src" 12 | 13 | [fortran] 14 | source-form = "default" 15 | implicit-external = true 16 | 17 | [dependencies] 18 | ferror = { git = "https://github.com/jchristopherson/ferror" } 19 | 20 | [dev-dependencies] 21 | fortran_test_helper = { git = "https://github.com/jchristopherson/fortran_test_helper" } 22 | 23 | [install] 24 | library = true 25 | 26 | [build] 27 | link = ["blas", "lapack"] 28 | auto-executables = false 29 | auto-examples = false 30 | auto-tests = false 31 | 32 | [[test]] 33 | name = "linalg_test" 34 | source-dir = "tests" 35 | main = "linalg_test.f90" -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "linalg-jchristopherson", 3 | "description": "A linear algebra library that provides a user-friendly interface to several BLAS and LAPACK routines.", 4 | "author": "Jason Christopherson", 5 | "version": "1.5.0" 6 | } -------------------------------------------------------------------------------- /sparskit2/BLASSM/apl.f: -------------------------------------------------------------------------------- 1 | subroutine aplsb (nrow,ncol,a,ja,ia,s,b,jb,ib,c,jc,ic,nzmax, 2 | * iw,ierr) 3 | real*8 a(*), b(*), c(*), s 4 | integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1), 5 | * iw(ncol) 6 | c----------------------------------------------------------------------- 7 | c performs the matrix sum C = A+s*B. 8 | c----------------------------------------------------------------------- 9 | c on entry: 10 | c --------- 11 | c nrow = integer. The row dimension of A and B 12 | c ncol = integer. The column dimension of A and B. 13 | c job = integer. Job indicator. When job = 0, only the structure 14 | c (i.e. the arrays jc, ic) is computed and the 15 | c real values are ignored. 16 | c 17 | c a, 18 | c ja, 19 | c ia = Matrix A in compressed sparse row format. 20 | c 21 | c s = real*8 - coefficient that multiplies B. 22 | c b, 23 | c jb, 24 | c ib = Matrix B in compressed sparse row format. 25 | c 26 | c nzmax = integer. The length of the arrays c and jc. 27 | c amub will stop if the result matrix C has a number 28 | c of elements that exceeds exceeds nzmax. See ierr. 29 | c 30 | c on return: 31 | c---------- 32 | c c, 33 | c jc, 34 | c ic = resulting matrix C in compressed sparse row sparse format. 35 | c 36 | c ierr = integer. serving as error message. 37 | c ierr = 0 means normal return, 38 | c ierr .gt. 0 means that aplsb1 stopped while computing the 39 | c i-th row of C with i=ierr, because the number 40 | c of elements in C exceeds nzmax. 41 | c 42 | c work arrays: 43 | c------------ 44 | c iw = integer work array of length equal to the number of 45 | c columns in A. 46 | c note: expanded row implementation. Does not require column indices to 47 | c be sorted. 48 | c----------------------------------------------------------------------- 49 | ierr = 0 50 | len = 0 51 | ic(1) = 1 52 | do 1 j=1, ncol 53 | iw(j) = 0 54 | 1 continue 55 | c 56 | do 500 ii=1, nrow 57 | c copy row ii to C 58 | do 200 ka=ia(ii), ia(ii+1)-1 59 | len = len+1 60 | jcol = ja(ka) 61 | if (len .gt. nzmax) goto 999 62 | jc(len) = jcol 63 | c(len) = a(ka) 64 | iw(jcol)= len 65 | 200 continue 66 | c 67 | do 300 kb=ib(ii),ib(ii+1)-1 68 | jcol = jb(kb) 69 | jpos = iw(jcol) 70 | if (jpos .eq. 0) then 71 | len = len+1 72 | if (len .gt. nzmax) goto 999 73 | jc(len) = jcol 74 | c(len) = s*b(kb) 75 | iw(jcol)= len 76 | else 77 | c(jpos) = c(jpos) + s*b(kb) 78 | endif 79 | 300 continue 80 | do 301 k=ic(ii), len 81 | iw(jc(k)) = 0 82 | 301 continue 83 | ic(ii+1) = len+1 84 | 500 continue 85 | return 86 | 999 ierr = ii 87 | return 88 | c------------end of aplsb1 --------------------------------------------- 89 | c----------------------------------------------------------------------- 90 | end 91 | c----------------------------------------------------------------------- 92 | -------------------------------------------------------------------------------- /sparskit2/DOC/README: -------------------------------------------------------------------------------- 1 | 2 | This directory contains some documentation on the package. 3 | 4 | paper.tex is the tex-file of the documentation. 5 | paper.ps is the post-script file 6 | QUICK_REF is a quick-reference file that contains all existing routines 7 | listed by module. * may need updating* 8 | 9 | all other files are pictures used by paper.tex. 10 | 11 | *THANKS: to Daniel Heiserer (BMW, germany) for a the recent update to 12 | the files (latex, figures..) in this directory 13 | 14 | ----------------------------------------------------------------------- 15 | -------------------------------------------------------------------------------- /sparskit2/DOC/dir.fig: -------------------------------------------------------------------------------- 1 | #FIG 2.1 2 | 80 2 3 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 4 | 49 244 319 99 9999 9999 5 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 6 | 319 99 134 244 9999 9999 7 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 8 | 319 99 204 244 9999 9999 9 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 10 | 319 99 264 244 9999 9999 11 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 12 | 319 99 324 244 9999 9999 13 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 14 | 319 99 394 244 9999 9999 15 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 16 | 319 99 484 244 9999 9999 17 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 18 | 319 99 569 244 9999 9999 19 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 20 | 544 304 564 264 9999 9999 21 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 22 | 564 264 614 304 9999 9999 23 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 24 | 344 304 389 264 9999 9999 25 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 26 | 389 264 399 304 9999 9999 27 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 28 | 389 264 454 304 9999 9999 29 | 2 1 0 1 -1 0 0 0 0.000 -1 0 0 30 | 319 99 319 99 634 244 634 244 9999 9999 31 | 4 0 0 14 0 -1 0 0.00000 4 10 58 19 259 BLASSM 32 | 4 0 0 14 0 -1 0 0.00000 4 10 68 99 259 FORMATS 33 | 4 0 0 14 0 -1 0 0.00000 4 10 34 189 259 INFO 34 | 4 0 0 14 0 -1 0 0.00000 4 10 45 239 259 INOUT 35 | 4 0 0 14 0 -1 0 0.00000 4 10 41 304 259 ITSOL 36 | 4 0 0 14 0 -1 0 0.00000 4 10 64 359 259 MATGEN 37 | 4 0 0 14 0 -1 0 0.00000 4 10 82 439 259 ORDERINGS 38 | 4 0 0 14 0 -1 0 0.00000 4 10 55 539 259 UNSUPP 39 | 4 0 0 12 0 -1 0 0.00000 4 9 50 519 319 MATEXP 40 | 4 0 0 12 0 -1 0 0.00000 4 9 29 329 319 FDIF 41 | 4 0 0 12 0 -1 0 0.00000 4 9 27 384 319 FEM 42 | 4 0 0 12 0 -1 0 0.00000 4 9 30 439 319 MISC 43 | 4 0 0 18 0 -1 0 0.00000 4 13 88 279 89 SPARSKIT 44 | 4 0 0 12 0 -1 0 0.00000 4 9 37 599 319 PLOTS 45 | 4 0 0 20 0 -1 0 0.00000 4 17 279 199 364 General organization of SPARSKIT 46 | 4 0 0 14 0 -1 0 0.00000 4 10 30 619 259 DOC 47 | -------------------------------------------------------------------------------- /sparskit2/DOC/dir.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/dir.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/doc_data.txt: -------------------------------------------------------------------------------- 1 | InfoKey: Creator 2 | InfoValue: fig2dev Version 3.2 Patchlevel 3c 3 | InfoKey: Title 4 | InfoValue: dir.pdf 5 | InfoKey: Author 6 | InfoValue: q127038@caek315 (Daniel Heiserer, EK-213, +49-89-382-21187) 7 | InfoKey: Producer 8 | InfoValue: GPL Ghostscript 8.15 9 | InfoKey: ModDate 10 | InfoValue: D:20050308101430 11 | InfoKey: CreationDate 12 | InfoValue: D:20050308101430 13 | PdfID0: 5eca9773bba4d12b8b37b446c3226559 14 | PdfID1: 5eca9773bba4d12b8b37b446c3226559 15 | NumberOfPages: 2 16 | -------------------------------------------------------------------------------- /sparskit2/DOC/jpwh.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/jpwh.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/mat8.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/mat8.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/mat9.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/mat9.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/msh8.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/msh8.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/msh9.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/msh9.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/paper.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/paper.pdf -------------------------------------------------------------------------------- /sparskit2/DOC/vbrpic.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jchristopherson/linalg/247b11aa1cd7b59fb99f1dee158e16e86dca9b4f/sparskit2/DOC/vbrpic.pdf -------------------------------------------------------------------------------- /sparskit2/INFO/info.saylr1: -------------------------------------------------------------------------------- 1 | * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 2 | * unsymmetric matrix of paul saylor - 14 by 17 2d grid may, 1983 * 3 | * Key = saylr1 , Type = rua * 4 | * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 5 | * Dimension N = 238 * 6 | * Number of nonzero elements = 1128 * 7 | * Average number of nonzero elements/Column = 4.7395 * 8 | * Standard deviation for above average = 0.4757 * 9 | * Nonzero elements in strict lower part = 445 * 10 | * Nonzero elements in strict upper part = 445 * 11 | * Nonzero elements in main diagonal = 238 * 12 | * Weight of longest column = 5 * 13 | * Weight of shortest column = 3 * 14 | * Weight of longest row = 5 * 15 | * Weight of shortest row = 3 * 16 | * Matching elements in symmetry = 1128 * 17 | * Relative Symmetry Match (symmetry=1) = 1.0000 * 18 | * Average distance of a(i,j) from diag. = 0.595E+01 * 19 | * Standard deviation for above average = 0.654E+01 * 20 | *-----------------------------------------------------------------* 21 | * Frobenius norm of A = 0.886E+09 * 22 | * Frobenius norm of symmetric part = 0.991E+09 * 23 | * Frobenius norm of nonsymmetric part = 0.443E+09 * 24 | * Maximum element in A = 0.306E+09 * 25 | * Percentage of weakly diagonally dominant rows = 0.761E+00 * 26 | * Percentage of weakly diagonally dominant columns = 0.744E+00 * 27 | *-----------------------------------------------------------------* 28 | * Lower bandwidth (max: i-j, a(i,j) .ne. 0) = 14 * 29 | * Upper bandwidth (max: j-i, a(i,j) .ne. 0) = 14 * 30 | * Maximum Bandwidth = 29 * 31 | * Average Bandwidth = 0.275E+02 * 32 | * Number of nonzeros in skyline storage = 6536 * 33 | * 90% of matrix is in the band of width = 27 * 34 | * 80% of matrix is in the band of width = 27 * 35 | * The total number of nonvoid diagonals is = 5 * 36 | * The 5 most important diagonals are (offsets) : * 37 | * 0 14 -14 1 -1 * 38 | * The accumulated percentages they represent are : * 39 | * 21.1 41.0 60.8 80.4 100.0 * 40 | *-----------------------------------------------------------------* 41 | * The matrix does not have a block structure * 42 | *-----------------------------------------------------------------* 43 | -------------------------------------------------------------------------------- /sparskit2/INFO/rinfo1.f: -------------------------------------------------------------------------------- 1 | program info1 2 | c---------------------------------------------------------------------- 3 | c usage info1.ex < HB_file 4 | c 5 | c where info1 is the executable generated by makefile, HB_file is a 6 | c file containing a matrix stored in Harwell-Boeing matrices. 7 | c Info1 will then dump the information into the standard output. 8 | c 9 | c To use with larger matrices, increase nmax and nzmax. 10 | c---------------------------------------------------------------------- 11 | implicit none 12 | integer nmax, nzmax 13 | parameter (nmax = 30000, nzmax = 800000) 14 | integer ia(nmax+1),ia1(nmax+1),ja(nzmax),ja1(nzmax) 15 | real*8 a(nzmax),a1(nzmax),rhs(1) 16 | character title*72, type*3, key*8, guesol*2 17 | logical valued 18 | c 19 | integer job, iin, nrow,ncol,nnz,ierr, nrhs, iout 20 | c-------------- 21 | data iin /5/, iout/6/ 22 | c-------------- 23 | job = 2 24 | nrhs = 0 25 | call readmt (nmax,nzmax,job,iin,a,ja,ia, rhs, nrhs, 26 | * guesol,nrow,ncol,nnz,title,key,type,ierr) 27 | c---- if not readable return 28 | if (ierr .ne. 0) then 29 | write (iout,100) ierr 30 | 100 format(' **ERROR: Unable to read matrix',/, 31 | * ' Message returned fom readmt was ierr =',i3) 32 | stop 33 | endif 34 | valued = (job .ge. 2) 35 | c------- 36 | call dinfo1(ncol,iout,a,ja,ia,valued,title,key,type,a1,ja1,ia1) 37 | c--------------------end------------------------------------------------ 38 | c----------------------------------------------------------------------- 39 | end 40 | -------------------------------------------------------------------------------- /sparskit2/INOUT/README: -------------------------------------------------------------------------------- 1 | c----------------------------------------------------------------------c 2 | c S P A R S K I T c 3 | c----------------------------------------------------------------------c 4 | C INPUT-OUTPUT MODULE c 5 | c----------------------------------------------------------------------c 6 | c contents: c 7 | c---------- c 8 | c readmt : reads matrices in the Boeing/Harwell format. c 9 | c prtmt : prints matrices in the Boeing/Harwell format. c 10 | c dump : outputs matrix rows in a simple format (debugging purposes)c 11 | c pspltm : generates a post-script plot of the non-zero pattern of A c 12 | c pltmt : produces a 'pic' file for plotting a sparse matrix c 13 | c smms : write the matrx in a format used in SMMS package c 14 | c readsm : reads matrics in coordinate format (as in SMMS package) c 15 | c readsk : reads matrices in CSR format (simplified H/B formate). c 16 | c skit : writes matrics to a file, format same as above. c 17 | c prtunf : writes matrics (in CSR format) unformatted c 18 | c readunf: reads unformatted data of matrics (in CSR format) c 19 | c----------------------------------------------------------------------c 20 | 21 | To visualize a Harwell-Boeing matrix on a Unix workstation, it is easiest 22 | to convert it to a postscript file and then view it with ghostview or gs. 23 | The program hb2ps.ex may be used for the former purpose. 24 | -------------------------------------------------------------------------------- /sparskit2/INOUT/hb2pic.f: -------------------------------------------------------------------------------- 1 | program hb2pic 2 | c------------------------------------------------------------------c 3 | c 4 | c reads a harwell-Boeing matrix and creates a pic file for pattern. 5 | c 6 | c------------------------------------------------------------------c 7 | implicit real*8 (a-h,o-z) 8 | parameter (nmax = 5000, nzmax = 70000) 9 | integer ia(nmax+1), ja(nzmax) 10 | real*8 a(nzmax), rhs(1) 11 | character title*72, key*8, guesol*2 12 | logical valued 13 | c-------------- 14 | data iin /5/, iout/6/ 15 | c-------------- 16 | job = 2 17 | nrhs = 0 18 | call readmt (nmax,nzmax,job,iin,a,ja,ia, rhs, nrhs, 19 | * guesol,nrow,ncol,nnz,title,key,type,ierr) 20 | c---- if not readable return 21 | if (ierr .ne. 0) then 22 | write (iout,100) ierr 23 | 100 format(' **ERROR: Unable to read matrix',/, 24 | * ' Message returned fom readmt was ierr =',i3) 25 | stop 26 | endif 27 | valued = (job .ge. 2) 28 | c------- 29 | mode = 1 30 | iounit = 6 31 | job = 11 32 | call pltmt (nrow,ncol,mode,ja,ia,title,key,type,job,iout) 33 | c----------------------------------------------------------------------- 34 | stop 35 | end 36 | -------------------------------------------------------------------------------- /sparskit2/INOUT/hb2ps.f: -------------------------------------------------------------------------------- 1 | program hb2ps 2 | c---------------------------------------------------------------------- 3 | c translates a harwell - boeing file into a post-script file. Usage: 4 | c hb2ps < HB_file > Postscript_file 5 | c where hb2ps is the executable generated from this program, 6 | c HB_file is a file containing a matrix stored in Harwell-Boeing 7 | c format and Postscript_file is a file to contain the post-script file. 8 | c---------------------------------------------------------------------- 9 | parameter (nmax = 10000, nzmax = 100000) 10 | integer ia(nmax+1),ja(nzmax), idummy(1), ptitle 11 | real*8 a(1),rhs(1) 12 | real size 13 | character title*72, key*8, guesol*2, munt*2 14 | data iin /5/, iout/6/, size/5.0/, nlines/0/, ptitle/0/,mode/0/ 15 | data munt/'in'/ 16 | c----------------------------------------------------------------------- 17 | job = 1 18 | nrhs = 0 19 | c 20 | c read matrix in Harwell-Boeing format 21 | c 22 | call readmt (nmax,nzmax,job,iin,a,ja,ia, rhs, nrhs, 23 | * guesol,nrow,ncol,nnz,title,key,type,ierr) 24 | c 25 | c if not readable return 26 | c 27 | if (ierr .ne. 0) then 28 | write (iout,100) ierr 29 | stop 30 | endif 31 | c 32 | c call post script generator 33 | c 34 | call pspltm(nrow,ncol,mode,ja,ia,title,ptitle,size,munt, 35 | * nlines,idummy,iout) 36 | c 37 | 100 format(' **ERROR: Unable to read matrix',/, 38 | * ' Message returned fom readmt was ierr =',i3) 39 | c----------------------------------------------------------------------- 40 | stop 41 | end 42 | 43 | -------------------------------------------------------------------------------- /sparskit2/ITSOL/README: -------------------------------------------------------------------------------- 1 | 2 | ----------------- 3 | Current contents: 4 | ----------------- 5 | 6 | Solvers 7 | ------- 8 | 9 | iters.f : This file currently has several basic iterative linear system 10 | solvers. They are: 11 | CG -- Conjugate Gradient Method 12 | CGNR -- Conjugate Gradient Method on Normal Residual equation 13 | BCG -- Bi-Conjugate Gradient Method 14 | BCGSTAB -- BCG stablized 15 | TFQMR -- Transpose-Free Quasi-Minimum Residual method 16 | GMRES -- Generalized Minimum RESidual method 17 | FGMRES -- Flexible version of Generalized Minimum RESidual method 18 | DQGMRES -- Direct verions of Quasi Generalized Minimum Residual 19 | method 20 | DBCG -- BCG with partial pivoting 21 | 22 | Preconditioners 23 | --------------- 24 | 25 | ilut.f : ILUT + GMRES: a combination of a robust preconditioner 26 | using dual thresholding for dropping strategy and 27 | the GMRES algorithm. ILU0 and MILU0 are also provided 28 | for comparison purposes. 29 | large number of updates on Feb 10, 1992 Y.S. 30 | ILUTP, or ILUT with partial pivoting is also provided. 31 | 32 | Drivers 33 | ------- 34 | 35 | rilut.f : test program for GMRES/ILU*. 36 | It tests three preconditioners ilu0, milu0 and ilut using 37 | GMRES as the solver. 38 | 39 | riters.f : test program for ITERS -- the basic iterative solvers 40 | with reverse communication. 41 | The test matrix is generated with GEN57PT. 42 | 43 | riter2.f : test program for ITERS. It reads a Harwell/Boeing matrix 44 | from the standard input. 45 | 46 | Other 47 | ----- 48 | 49 | itaux.f : The file contains some of the auxiliary functions that is 50 | required to run the test prgram rilut.f and riters.f It 51 | includes the routine that drive the reverse-communincation 52 | routines and the definitions of the partial differential 53 | equations used to generate the matrix in rilut.f and 54 | riters.f. 55 | 56 | executables 57 | ----------- 58 | 59 | rilut.ex : generated by "make rilut.ex" from the driver rilut.f 60 | riters.ex : generated by "make riters.ex" from the driver riters.f 61 | riter2.ex : generated by "make riter2.ex" from the driver riter2.f 62 | 63 | see makefile for the details of the dependencies. 64 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/FDIF/README: -------------------------------------------------------------------------------- 1 | This directory contains the routines that generate finite difference 2 | matrices from a second order elliptic operator. 3 | 4 | 1) 5-pt and 7-pt matrices on rectangular regions discretizing 5 | elliptic operators of the form: 6 | 7 | L u == delx( a delx u ) + dely ( b dely u) + delz ( c delz u ) + 8 | delx ( d u ) + dely (e u) + delz( f u ) + g u = h u 9 | 10 | with Boundary conditions, 11 | alpha del u / del n + beta u = gamma 12 | on a rectangular 1-D, 2-D or 3-D grid using centered 13 | difference scheme or upwind scheme. 14 | 15 | The functions a, b, ..., h are known through the 16 | subroutines afun, bfun, ..., hfun in the file 17 | functns.f. The alpha is a constant on each side of the 18 | rectanglar domain. the beta and the gamma are defined 19 | by the functions betfun and gamfun (see functns.f for 20 | examples). 21 | 22 | 2) block version of the finite difference matrices (several degrees of 23 | freedom per grid point. ) It only generates the matrix (without 24 | the right-hand-side), only Dirichlet Boundary conditions are used. 25 | 26 | genmat.f ---- the matrix generation routines. 27 | functns.f --- functions used by the genmat.f 28 | 29 | to test the 5-point/7-point matrix please see mak57pt 30 | to test the block version of the 5-point/7-point matrix see mak57bl 31 | 32 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/FDIF/rgen5pt.f: -------------------------------------------------------------------------------- 1 | program fivept 2 | c----------------------------------------------------------------------- 3 | c main program for generating 5 point and 7-point matrices in the 4 | c Harwell-Boeing format. Creates a file with containing a 5 | c harwell-boeing matrix. typical session: 6 | c user answer are after the colon 7 | c Enter nx, ny, nz : 10 10 1 8 | c Filename for matrix: test.mat 9 | c output matrix in data file : test.mat 10 | c 11 | c nz = 1 will create a 2-D problem 12 | c 13 | c----------------------------------------------------------------------- 14 | integer nmx, nxmax 15 | parameter (nxmax = 50, nmx = nxmax*nxmax) 16 | c implicit none 17 | integer ia(nmx),ja(7*nmx),iau(nmx) 18 | real*8 a(7*nmx),rhs(nmx),al(6) 19 | character title*72, key*8, type*3, matfile*50, guesol*2 20 | c----------------------------------------------------------------------- 21 | integer nx, ny, nz, iout, n, ifmt, job 22 | write (6,*) ' ' 23 | write(6,'(22hEnter nx, ny, nz : ,$)') 24 | read (5,*) nx, ny, nz 25 | write(6,'(22hFilename for matrix : ,$)') 26 | read(5,'(a50)') matfile 27 | open (unit=7,file=matfile) 28 | c 29 | c boundary condition is partly specified here 30 | c 31 | c al(1) = 1.0D0 32 | c al(2) = 0.0D0 33 | c al(3) = 2.3D1 34 | c al(4) = 0.4D0 35 | c al(5) = 0.0D0 36 | c al(6) = 8.2D-2 37 | al(1) = 0.0D0 38 | al(2) = 0.0D0 39 | al(3) = 0.0D1 40 | al(4) = 0.0D0 41 | al(5) = 0.0D0 42 | al(6) = 0.0D0 43 | c 44 | call gen57pt (nx,ny,nz,al,0,n,a,ja,ia,iau,rhs) 45 | iout = 7 46 | c 47 | c write out the matrix 48 | c 49 | guesol='NN' 50 | title = 51 | * ' 5-POINT TEST MATRIX FROM SPARSKIT ' 52 | c '123456789012345678901234567890123456789012345678901234567890 53 | type = 'RUA' 54 | key ='SC5POINT' 55 | C 12345678 56 | ifmt = 15 57 | job = 2 58 | c upper part only?? 59 | c call getu (n, a, ja, ia, a, ja, ia) 60 | call prtmt (n,n,a,ja,ia,rhs,guesol,title,key,type, 61 | 1 ifmt,job,iout) 62 | write (6,*) ' output matrix in data file : ', matfile 63 | c 64 | stop 65 | end 66 | 67 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/FDIF/rgenblk.f: -------------------------------------------------------------------------------- 1 | program bfivept 2 | c----------------------------------------------------------------------- 3 | c main program for generating BLOCK 5 point and 7-point matrices in the 4 | c Harwell-Boeing format. Creates a file with containing a 5 | c harwell-boeing matrix. 6 | c 7 | c max block size = 5 8 | c max number of grid points = 8000 = ( nx * ny * nz .le. 8000) 9 | c matrix dimension = (nx*ny*nz* Block-size**2) .le. 8000 * 25= 200,000 10 | c 11 | c typical session: 12 | c Enter nx, ny, nz : 10 10 1 13 | c enter block-size : 4 14 | c enter filename for matrix: test.mat 15 | c output matrix in data file : test.mat 16 | c 17 | c nz =1 will create a 2-D problem 18 | c----------------------------------------------------------------------- 19 | parameter (nxmax = 20, nmx = nxmax*nxmax*nxmax, ntot=nmx*25) 20 | integer ia(ntot),ja(ntot),iau(ntot), iao(ntot),jao(ntot) 21 | real*8 stencil(7,100), a(ntot), ao(ntot) 22 | character title*72,key*8,type*3, matfile*50, guesol*2 23 | c----------------------------------------------------------------------- 24 | write (6,*) ' ' 25 | write(6,'(22hEnter nx, ny, nz : ,$)') 26 | read (5,*) nx, ny, nz 27 | write(6,'(22hnfree (Block size) : ,$)') 28 | read (5,*) nfree 29 | 30 | write(6,'(22hFilename for matrix : ,$)') 31 | 32 | read(5,'(a50)') matfile 33 | open (unit=7,file=matfile) 34 | c 35 | write (6,*) ' output in data file : ', matfile 36 | 37 | c------------------------------------------------------ 38 | na = nfree*nfree 39 | c 40 | call gen57bl (nx,ny,nz,nfree,na,n,a,ja,ia,iau,stencil) 41 | c------------------------------------------------------ 42 | 43 | print *, ' n=', n, ' nfree ', nfree, ' na =', na 44 | 45 | call bsrcsr(1,n,nfree, na, a, ja, ia, ao, jao, iao) 46 | n = n * nfree ! Apr. 21, 1995 47 | 48 | guesol='NN' 49 | 50 | title = 51 | * ' BLOCK 5-POINT TEST MATRIX FROM SPARSKIT ' 52 | type = 'RUA' 53 | key = 'BLOCK5PT' 54 | C 12345678 55 | ifmt = 15 56 | job = 2 57 | iout = 7 58 | call prtmt (n,n,ao,jao,iao,rhs,guesol,title,key,type, 59 | 1 ifmt,job,iout) 60 | print *, ' output in data file : ', matfile 61 | c 62 | stop 63 | end 64 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/FEM/README: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------- 2 | 3 | SPARSKIT Modules FEM 4 | 5 | --------------------------------------------------------------- 6 | 7 | This directory contains the SPARSKIT FEM module, 8 | a matrix generator for finite element matrices. 9 | 10 | contents: 11 | ========= 12 | 13 | convdif.f == a driver to generate a matrix and some associated plots 14 | functns2.o == functions needed by the driver -- define the coefficients 15 | of the PDE 16 | meshes.f == set of sample meshes defined as inout to the driver 17 | makefile == a makefile for an executable to generate a sample mesh 18 | elmtlib2.f == a small finite element library 19 | 20 | mat.hb is a test matrix. 21 | 22 | Two output files are provided: mat.ps and msh.ps. You may wish to save 23 | these to another name before running the test program so that you may 24 | compare your output to these files. 25 | 26 | ----------------------------------------------------------------------- 27 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/MISC/README: -------------------------------------------------------------------------------- 1 | This directory contains the last two test problems as described in 2 | README of the directory above this one. 3 | 4 | zlatev.f : three different codes to generate matrices from the 5 | Zlatev et. al. paper (see above). Contributed by E. Rothman 6 | (Cornell). 7 | 8 | rzlatev.f : driver for a test program for the zlatev code. 9 | 10 | makzlatev : makefiles. See above for details. 11 | 12 | markov.f : a main program followed by a subroutine to generate 13 | markov chain matrices modeling random walk on a triang. 14 | grid. There is one parameter to the subroutine. 15 | 16 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/MISC/rsobel.f: -------------------------------------------------------------------------------- 1 | program rsobel 2 | integer n, ia(1:200), ja(1:1000), ib(1:200), jb(1:1000) 3 | integer nrowc, ncolc 4 | integer ic(1:200), jc(1:1000), ierr 5 | real*8 a(1:1000), b(1:1000), c(1:1000) 6 | 7 | write (*, '(1x, 9hInput n: ,$)') 8 | read *, n 9 | call sobel(n,nrowc,ncolc,c,jc,ic,a,ja,ia,b,jb,ib,1000,ierr) 10 | print *, 'ierr =', ierr 11 | print *, 'Nrow =', nrowc, ' Ncol =', ncolc 12 | call dump(1, nrowc, .true., c, jc, ic, 6) 13 | end 14 | 15 | -------------------------------------------------------------------------------- /sparskit2/MATGEN/README: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------- 2 | SPARSKIT MODULE MATGEN 3 | ------------------------------------------------------------- 4 | 5 | The current directory MATGEN contains a few subroutines and 6 | drivers for generating sparse matrices. 7 | 8 | 1) 5-pt and 7-pt matrices on rectangular regions discretizing 9 | elliptic operators of the form: 10 | 11 | L u == delx( a delx u ) + dely ( b dely u) + delz ( c delz u ) + 12 | delx ( d u ) + dely (e u) + delz( f u ) + g u = h u 13 | 14 | with Boundary conditions, 15 | alpha del u / del n + beta u = gamma 16 | on a rectangular 1-D, 2-D or 3-D grid using centered 17 | difference scheme or upwind scheme. 18 | 19 | The functions a, b, ..., h are known through the 20 | subroutines afun, bfun, ..., hfun in the file 21 | functns.f. The alpha is a constant on each side of the 22 | rectanglar domain. the beta and the gamma are defined 23 | by the functions betfun and gamfun (see functns.f for 24 | examples). 25 | 26 | 2) block version of the finite difference matrices (several degrees of 27 | freedom per grid point. ) It only generates the matrix (without 28 | the right-hand-side), only Dirichlet Boundary conditions are used. 29 | 30 | 3) Finite element matrices for the convection-diffusion problem 31 | 32 | - Div ( K(x,y) Grad u ) + C(x,y) Grad u = f 33 | u = 0 on boundary 34 | 35 | (with Dirichlet boundary conditions). The matrix is returned 36 | assembled in compressed sparse row format. See genfeu for 37 | matrices in unassembled form. The user must provide the grid, 38 | (coordinates x, y and connectivity matrix ijk) as well as some 39 | information on the nodes (nodcode) and the material properties 40 | (the function K(x,y) above) in the form of a subroutine xyk. 41 | 42 | 4) Markov chain matrices arising from a random walk on a 43 | trangular grid. Useful for testing nonsymmetric eigenvalue 44 | codes. Has been suggested by G.W. Stewart in one of his 45 | papers. Used by Y. Saad in several papers as a test problem 46 | for nonsymmetric eigenvalue methods. 47 | 48 | 5) Matrices from the paper by Z. Zlatev, K. Schaumburg, 49 | and J. Wasniewski. (``A testing scheme for subroutines solving 50 | large linear problems.'' Computers and Chemistry, 5:91--100, 51 | 1981.) 52 | 53 | ---------------------------------------------------------------------- 54 | the items (1) and (2) are in directory FDIF, 55 | the item (3) is in directory FEM 56 | the items (4) and (5) are in directory MISC 57 | 58 | -------------------------------------------------------------------------------- /sparskit2/ORDERINGS/README: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------ 2 | SPARSKIT MODULE ORDERINGS 3 | ------------------------------------------------------------- 4 | 5 | The current directory ORDERINGS contains a few subroutines for 6 | finding some of the standard reorderings for a given matrix. 7 | 8 | levset.f -- level set based algorithms 9 | 10 | dblstr : doubled stripe partitioner 11 | rdis : recursive dissection partitioner 12 | dse2way : distributed site expansion usuing sites from dblstr 13 | dse : distributed site expansion usuing sites from rdis 14 | BFS : Breadth-First search traversal algorithm 15 | add_lvst : routine to add a level -- used by BFS 16 | stripes : finds the level set structure 17 | stripes0 : finds a trivial one-way partitioning from level-sets 18 | perphn : finds a pseudo-peripheral node and performs a BFS from it. 19 | mapper4 : routine used by dse and dse2way to do center expansion 20 | get_domns: routine to find subdomaine from linked lists found by 21 | mapper4. 22 | add_lk : routine to add entry to linked list -- used by mapper4. 23 | find_ctr : routine to locate an approximate center of a subgraph. 24 | rversp : routine to reverse a given permutation (e.g., for RCMK) 25 | maskdeg : integer function to compute the `masked' of a node 26 | 27 | color.f -- algorithms for independent set ordering and multicolor 28 | orderings 29 | 30 | multic : greedy algorithm for multicoloring 31 | indset0 : greedy algorithm for independent set ordering 32 | indset1 : independent set ordering using minimal degree traversal 33 | indset2 : independent set ordering with local minimization 34 | indset3 : independent set ordering by vertex cover algorithm 35 | 36 | ccn.f -- code for strongly connected components 37 | 38 | blccnx : Driver routine to reduce the structure of a matrix 39 | to its strongly connected components. 40 | cconex : Main routine to compute the strongly connected components 41 | of a (block diagonal) matrix. 42 | anccnx : We put in ICCNEX the vertices marked in the component MCCNEX. 43 | newcnx : We put in ICCNEX the vertices marked in the component 44 | MCCNEX. We modify also the vector KPW. 45 | blccn1 : Parallel computation of the connected components of a 46 | matrix. The parallel loop is performed only if the matrix 47 | has a block diagonal structure. 48 | icopy : We copy an integer vector into anothoer. 49 | compos : We calculate the composition between two permutation 50 | vectors. 51 | invlpw : We calculate the inverse of a permutation vector. 52 | numini : We initialize a vector to the identity. 53 | tbzero : We initialize to ZERO an integer vector. 54 | iplusa : Given two integers IALPHA and IBETA, for an integer vector 55 | IA we calculate IA(i) = ialpha + ibeta * ia(i) 56 | -------------------------------------------------------------------------------- /sparskit2/UNSUPP/MATEXP/README: -------------------------------------------------------------------------------- 1 | 2 | SUBDIRECTORY MATEXP 3 | ------------------- 4 | routines related to matrix exponentials. 5 | 6 | contents: 7 | ---------- 8 | exppro.f computes exp( t A) v 9 | rexp.f a simple test program for exppro.f 10 | phipro.f solves y'= A y + b 11 | rphi.f a simple test program for phipro.f 12 | makefile makefile for the test problems. make exp.ex will make 13 | an executable for exppro, make phi.ex will test program for 14 | phipro.f 15 | 16 | 17 | feedback appreciated. BEWARE: DOCUMENTATION MAY BE INACCURATE - 18 | --------------------- VERY LITTLE TESTING DONE WITH PHIPRO.F -- 19 | 20 | 21 | -------------------------------------------------------------------------------- /sparskit2/UNSUPP/MATEXP/rexp.f: -------------------------------------------------------------------------------- 1 | program exptest 2 | c------------------------------------------------------------------- 3 | c 4 | c Test program for exponential propagator using Arnoldi approach 5 | c This main program is a very simple test using diagonal matrices 6 | c (Krylov subspace methods are blind to the structure of the matrix 7 | c except for symmetry). This provides a good way of testing the 8 | c accuracy of the method as well as the error estimates. 9 | c 10 | c------------------------------------------------------------------- 11 | implicit real*8 (a-h,o-z) 12 | parameter (nmax = 400, ih0=60, ndmx=20,nzmax = 7*nmax) 13 | real*8 a(nzmax), u(ih0*nmax), w(nmax),w1(nmax),x(nmax),y(nmax) 14 | integer ioff(10) 15 | data iout/6/, a0/0.0/, b0/1.0/, epsmac/1.d-10/, eps /1.d-10/ 16 | c 17 | c set dimension of matrix 18 | c 19 | n = 100 20 | c--------------------------- define matrix ----------------------------- 21 | c A is a single diagonal matrix (ndiag = 1 and ioff(1) = 0 ) 22 | c----------------------------------------------------------------------- 23 | ndiag = 1 24 | ioff(1) = 0 25 | c 26 | c-------- entries in the diagonal are uniformly distributed. 27 | c 28 | h = 1.0d0 / real(n+1) 29 | do 1 j=1, n 30 | a(j) = real(j+1)* h 31 | 1 continue 32 | c-------- 33 | write (6,'(10hEnter tn: ,$)') 34 | read (5,*) tn 35 | c 36 | write (6,'(36hEpsilon (desired relative accuracy): ,$)') 37 | read (5,*) eps 38 | c------- 39 | write (6,'(36h m (= dimension of Krylov subspace): ,$)') 40 | read (5,*) m 41 | c------- 42 | c define initial conditions: chosen so that solution = (1,1,1,1..1)^T 43 | c------- 44 | do 2 j=1,n 45 | w(j) = dexp(a(j)*tn) 46 | 2 w1(j) = w(j) 47 | c 48 | call expprod (n, m, eps, tn, u, w, x, y, a, ioff, ndiag) 49 | c 50 | print *, ' final answer ' 51 | print *, (w(k),k=1,20) 52 | c 53 | do 4 k=1,n 54 | 4 w1(k) = dexp(-a(k)*tn) * w1(k) 55 | print *, ' exact solution ' 56 | print *, (w1(k),k=1,20) 57 | c 58 | c---------- computing actual 2-norm of error ------------------ 59 | c 60 | t = 0.0d0 61 | do 47 k=1,n 62 | 47 t = t+ (w1(k)-w(k))**2 63 | t = dsqrt(t / ddot(n, w,1,w,1) ) 64 | c 65 | write (6,*) ' final error', t 66 | c-------------------------------------------------------------- 67 | stop 68 | end 69 | c------- 70 | subroutine oped(n,x,y,diag,ioff,ndiag) 71 | c====================================================== 72 | c this kernel performs a matrix by vector multiplication 73 | c for a diagonally structured matrix stored in diagonal 74 | c format 75 | c====================================================== 76 | implicit real*8 (a-h,o-z) 77 | real*8 x(n), y(n), diag(n,ndiag) 78 | common nope, nmvec 79 | integer j, n, ioff(ndiag) 80 | CDIR$ IVDEP 81 | do 1 j=1, n 82 | y(j) = 0.00 83 | 1 continue 84 | c 85 | do 10 j=1,ndiag 86 | io = ioff(j) 87 | i1=max0(1,1-io) 88 | i2=min0(n,n-io) 89 | CDIR$ IVDEP 90 | do 9 k=i1,i2 91 | y(k) = y(k)+diag(k,j)*x(k+io) 92 | 9 continue 93 | 10 continue 94 | nmvec = nmvec + 1 95 | nope = nope + 2*ndiag*n 96 | return 97 | end 98 | c 99 | -------------------------------------------------------------------------------- /sparskit2/UNSUPP/PLOTS/README: -------------------------------------------------------------------------------- 1 | 2 | ----------------- 3 | Current contents: 4 | ----------------- 5 | 6 | Some of the files that were originally in this directory 7 | have been moved to the INOUT module, or were obsolte and removed. 8 | 9 | * psgrd.f contains subroutine "psgrid" which plots a symmetric graph. 10 | 11 | * texplt1.f contains subroutine "texplt" allows several matrices 12 | in the same picture by calling texplt several times and exploiting job and 13 | different shifts. 14 | 15 | * texgrid1.f contains subroutine "texgrd" which generates tex commands 16 | for plotting a symmetric graph associated with a mesh. Allows 17 | several grids in the same picture by calling texgrd several times and 18 | exploiting job and different shifts. 19 | 20 | -------------------------------------------------------------------------------- /sparskit2/UNSUPP/README: -------------------------------------------------------------------------------- 1 | 2 | ---------- 3 | | UNSUPP | 4 | ---------- 5 | 6 | This is meant to contain any subroutine that is not part 7 | of SPARSKIT proper (for example preconditioners, iterative 8 | solvers, plotting and other tools,...) but which are 9 | nevertheless provided with the understanding that they may 10 | not be the best codes around or that there is further work 11 | needed on them.. 12 | 13 | CONTRIBUTIONS REQUESTED. 14 | ----------------------- 15 | ----------------- 16 | Current contents: 17 | ----------------- 18 | SUBDIRECTORY BLAS1 19 | ------------------ 20 | 21 | * blas1.f : includes subroutines: 22 | dcopy : copies a vector, x, to a vector, y. 23 | ddot : dot product of two vectors. 24 | csscal: scales a complex vector by a real constant. 25 | cswap : interchanges two vectors. 26 | csrot : applies a plane rotation. 27 | cscal : scales a vector by a constant. 28 | ccopy : copies a vector, x, to a vector, y. 29 | drotg : construct givens plane rotation. 30 | drot : applies a plane rotation. 31 | dswap : interchanges two vectors. 32 | dscal : scales a vector by a constant. 33 | daxpy : constant times a vector plus a vector. 34 | 35 | SUBDIRECTORY PLOTS 36 | ------------------ 37 | 38 | * psgrd.f contains subroutine "psgrid" which plots a symmetric graph. 39 | 40 | * texplt1.f contains subroutine "texplt" allows several matrices 41 | in the same picture by calling texplt several times and exploiting job and 42 | different shifts. 43 | 44 | * texgrid1.f contains subroutine "texgrd" which generates tex commands 45 | for plotting a symmetric graph associated with a mesh. Allows 46 | several grids in the same picture by calling texgrd several times and 47 | exploiting job and different shifts. 48 | 49 | 50 | SUBDIRECTORY MATEXP 51 | ------------------- 52 | routines related to matrix exponentials. 53 | 54 | 55 | * exppro.f computes w=exp( t A) v -- + a simple test program rexp.f 56 | * phipro.f computes w = phi(At)v, where phi(x)=(1-exp(x))/x; 57 | Also allows to solve the P.D.E. system y'= A y + b 58 | -------------------------------------------------------------------------------- /src/linalg.f90: -------------------------------------------------------------------------------- 1 | ! linalg.f90 2 | 3 | module linalg 4 | use linalg_sparse 5 | use linalg_basic 6 | use linalg_sorting 7 | use linalg_eigen 8 | use linalg_lu 9 | use linalg_rz 10 | use linalg_qr 11 | use linalg_tri 12 | use linalg_cholesky 13 | use linalg_lq 14 | use linalg_svd 15 | use linalg_inverse 16 | use linalg_least_squares 17 | implicit none 18 | private 19 | 20 | ! LINALG_BASIC.F90 21 | public :: LA_NO_OPERATION 22 | public :: LA_TRANSPOSE 23 | public :: LA_HERMITIAN_TRANSPOSE 24 | public :: mtx_mult 25 | public :: rank1_update 26 | public :: diag_mtx_mult 27 | public :: trace 28 | public :: mtx_rank 29 | public :: det 30 | public :: swap 31 | public :: recip_mult_array 32 | public :: tri_mtx_mult 33 | public :: band_mtx_mult 34 | public :: band_mtx_to_full_mtx 35 | public :: band_diag_mtx_mult 36 | public :: banded_to_dense 37 | public :: dense_to_banded 38 | public :: extract_diagonal 39 | 40 | ! LINALG_SPARSE.F90 41 | public :: csr_matrix 42 | public :: msr_matrix 43 | public :: size 44 | public :: create_empty_csr_matrix 45 | public :: create_empty_msr_matrix 46 | public :: nonzero_count 47 | public :: dense_to_csr 48 | public :: diag_to_csr 49 | public :: banded_to_csr 50 | public :: csr_to_dense 51 | public :: csr_to_msr 52 | public :: msr_to_csr 53 | public :: dense_to_msr 54 | public :: msr_to_dense 55 | public :: create_csr_matrix 56 | public :: matmul 57 | public :: operator(+) 58 | public :: operator(-) 59 | public :: operator(*) 60 | public :: operator(/) 61 | public :: assignment(=) 62 | public :: transpose 63 | public :: sparse_direct_solve 64 | public :: pgmres_solver 65 | 66 | ! LINALG_SORTING.F90 67 | public :: sort 68 | 69 | ! LINALG_EIGEN.F90 70 | public :: eigen 71 | 72 | ! LINALG_LU.F90 73 | public :: lu_factor 74 | public :: form_lu 75 | public :: solve_lu 76 | 77 | ! LINALG_RZ.F90 78 | public :: rz_factor 79 | public :: mult_rz 80 | 81 | ! LINALG_QR.F90 82 | public :: qr_factor 83 | public :: form_qr 84 | public :: mult_qr 85 | public :: qr_rank1_update 86 | public :: solve_qr 87 | 88 | ! LINALG_TRI.F90 89 | public :: solve_triangular_system 90 | 91 | ! LINALG_CHOLESKY.F90 92 | public :: cholesky_factor 93 | public :: cholesky_rank1_update 94 | public :: cholesky_rank1_downdate 95 | public :: solve_cholesky 96 | 97 | ! LINALG_LQ.F90 98 | public :: lq_factor 99 | public :: form_lq 100 | public :: mult_lq 101 | public :: solve_lq 102 | 103 | ! LINALG_SVD.F90 104 | public :: svd 105 | 106 | ! LINALG_INVERSE.F90 107 | public :: mtx_inverse 108 | public :: mtx_pinverse 109 | 110 | ! LINALG_LEAST_SQUARES.F90 111 | public :: solve_least_squares 112 | public :: solve_least_squares_full 113 | public :: solve_least_squares_svd 114 | 115 | end module 116 | -------------------------------------------------------------------------------- /src/qrupdate.f90: -------------------------------------------------------------------------------- 1 | !> @brief A module providing explicit interfaces for the QRUPDATE library. 2 | module qrupdate 3 | implicit none 4 | 5 | interface 6 | subroutine DQR1UP(m, n, k, q, ldq, r, ldr, u, v, w) 7 | use iso_fortran_env, only : int32, real64 8 | integer(int32), intent(in) :: m, n, k, ldq, ldr 9 | real(real64), intent(inout) :: q(ldq,*), r(ldr,*), u(*), v(*) 10 | real(real64), intent(out) :: w(*) 11 | end subroutine 12 | 13 | subroutine ZQR1UP(m, n, k, q, ldq, r, ldr, u, v, w, rw) 14 | use iso_fortran_env, only : int32, real64 15 | integer(int32), intent(in) :: m, n, k, ldq, ldr 16 | complex(real64), intent(inout) :: q(ldq,*), r(ldr,*), u(*), v(*) 17 | complex(real64), intent(out) :: w(*) 18 | real(real64), intent(out) :: rw(*) 19 | end subroutine 20 | 21 | subroutine DCH1UP(n, r, ldr, u, w) 22 | use iso_fortran_env, only : int32, real64 23 | integer(int32), intent(in) :: n, ldr 24 | real(real64), intent(inout) :: r(ldr,*), u(*) 25 | real(real64), intent(out) :: w(*) 26 | end subroutine 27 | 28 | subroutine ZCH1UP(n, r, ldr, u, w) 29 | use iso_fortran_env, only : int32, real64 30 | integer(int32), intent(in) :: n, ldr 31 | complex(real64), intent(inout) :: r(ldr,*), u(*) 32 | real(real64), intent(out) :: w(*) 33 | end subroutine 34 | 35 | subroutine DCH1DN(n, r, ldr, u, w, info) 36 | use iso_fortran_env, only : int32, real64 37 | integer(int32), intent(in) :: n, ldr 38 | real(real64), intent(inout) :: r(ldr,*), u(*) 39 | real(real64), intent(out) :: w(*) 40 | integer(int32), intent(out) :: info 41 | end subroutine 42 | 43 | subroutine ZCH1DN(n, r, ldr, u, rw, info) 44 | use iso_fortran_env, only : int32, real64 45 | integer(int32), intent(in) :: n, ldr 46 | complex(real64), intent(inout) :: r(ldr,*), u(*) 47 | real(real64), intent(out) :: rw(*) 48 | integer(int32), intent(out) :: info 49 | end subroutine 50 | end interface 51 | end module -------------------------------------------------------------------------------- /src/qrupdate/caxcpy.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine caxcpy(n,a,x,incx,y,incy) 22 | c purpose: constant times a conjugated vector plus a vector. 23 | c arguments: 24 | c n (in) vector length 25 | c a (in) complex factor 26 | c x (in) added vector 27 | c incx (in) x increments 28 | c y (io) accumulator vector 29 | c incy (in) y increments 30 | c 31 | integer n,incx,incy 32 | complex a,x(*),y(*) 33 | integer i,ix,iy 34 | c quick return if possible. 35 | if (n <= 0) return 36 | if (incx /= 1 .or. incy /= 1) then 37 | c code for unequal increments or equal increments not equal to 1 38 | ix = 1 39 | iy = 1 40 | if (incx.lt.0) ix = (-n+1)*incx + 1 41 | if (incy.lt.0) iy = (-n+1)*incy + 1 42 | do i = 1,n 43 | y(iy) = y(iy) + a*conjg(x(ix)) 44 | ix = ix + incx 45 | iy = iy + incy 46 | end do 47 | else 48 | c code for both increments equal to 1 49 | do i = 1,n 50 | y(i) = y(i) + a*conjg(x(i)) 51 | end do 52 | end if 53 | end subroutine 54 | -------------------------------------------------------------------------------- /src/qrupdate/cch1up.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cch1up(n,R,ldr,u,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a hermitian positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A + u*u' 26 | c (complex version) 27 | c arguments: 28 | c n (in) the order of matrix R 29 | c R (io) on entry, the upper triangular matrix R 30 | c on exit, the updated matrix R1 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c u (io) the vector determining the rank-1 update 33 | c on exit, u contains the rotation sines 34 | c used to transform R to R1. 35 | c w (out) cosine parts of rotations. 36 | c 37 | integer n,ldr 38 | complex R(ldr,*),u(*) 39 | real w(*) 40 | external clartg 41 | complex rr,ui,t 42 | integer i,j 43 | 44 | do i = 1,n 45 | c apply stored rotations, column-wise 46 | ui = conjg(u(i)) 47 | do j = 1,i-1 48 | t = w(j)*R(j,i) + u(j)*ui 49 | ui = w(j)*ui - conjg(u(j))*R(j,i) 50 | R(j,i) = t 51 | end do 52 | c generate next rotation 53 | call clartg(R(i,i),ui,w(i),u(i),rr) 54 | R(i,i) = rr 55 | end do 56 | end subroutine 57 | 58 | -------------------------------------------------------------------------------- /src/qrupdate/cchdex.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cchdex(n,R,ldr,j,rw) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a hermitian positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(jj,jj), where jj = [1:j-1,j+1:n+1]. 26 | c (complex version) 27 | c arguments: 28 | c n (in) the order of matrix R. 29 | c R (io) on entry, the original upper trapezoidal matrix R. 30 | c on exit, the updated matrix R1. 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c j (in) the position of the deleted row/column. 33 | c rw (out) a real workspace vector of size n. 34 | c 35 | integer n,ldr,j 36 | complex R(ldr,*) 37 | real rw(*) 38 | integer info,i 39 | external xerbla,ccopy,cqhqr 40 | 41 | c quick return if possible 42 | if (n == 1) return 43 | 44 | c check arguments 45 | info = 0 46 | if (n < 0) then 47 | info = 1 48 | else if (j < 1 .or. j > n) then 49 | info = 4 50 | end if 51 | if (info /= 0) then 52 | call xerbla('CCHDEX',info) 53 | return 54 | end if 55 | 56 | c delete the j-th column. 57 | do i = j,n-1 58 | call ccopy(n,R(1,i+1),1,R(1,i),1) 59 | end do 60 | c retriangularize. 61 | if (j < n) then 62 | call cqhqr(n+1-j,n-j,R(j,j),ldr,rw,R(1,n)) 63 | end if 64 | end subroutine 65 | -------------------------------------------------------------------------------- /src/qrupdate/cchshx.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cchshx(n,R,ldr,i,j,w,rw) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(p,p), where p is the permutation 26 | c [1:i-1,shift(i:j,-1),j+1:n] if i < j or 27 | c [1:j-1,shift(j:i,+1),i+1:n] if j < i. 28 | c (complex version) 29 | c arguments: 30 | c n (in) the order of matrix R 31 | c R (io) on entry, the upper triangular matrix R 32 | c on exit, the updated matrix R1 33 | c ldr (in) leading dimension of R. ldr >= n. 34 | c i (in) the first index determining the range (see above). 35 | c j (in) the second index determining the range (see above). 36 | c w (o) a workspace vector of size n. 37 | c rw (o) a real workspace vector of size n. 38 | c 39 | integer n,ldr,i,j 40 | complex R(ldr,*),w(*) 41 | real rw(*) 42 | external xerbla,ccopy,cqrtv1,cqrqh,cqhqr 43 | integer info,l 44 | c quick return if possible. 45 | if (n == 0 .or. n == 1) return 46 | info = 0 47 | c check arguments. 48 | if (n < 0) then 49 | info = 1 50 | else if (i < 1 .or. i > n) then 51 | info = 4 52 | else if (j < 1 .or. j > n) then 53 | info = 5 54 | end if 55 | if (info /= 0) then 56 | call xerbla('CCHSHX',info) 57 | return 58 | end if 59 | 60 | if (i < j) then 61 | c shift columns 62 | call ccopy(n,R(1,i),1,w,1) 63 | do l = i,j-1 64 | call ccopy(n,R(1,l+1),1,R(1,l),1) 65 | end do 66 | call ccopy(n,w,1,R(1,j),1) 67 | c retriangularize 68 | call cqhqr(n+1-i,n+1-i,R(i,i),ldr,rw,w) 69 | else if (j < i) then 70 | c shift columns 71 | call ccopy(n,R(1,i),1,w,1) 72 | do l = i,j+1,-1 73 | call ccopy(n,R(1,l-1),1,R(1,l),1) 74 | end do 75 | call ccopy(n,w,1,R(1,j),1) 76 | c eliminate the introduced spike. 77 | call cqrtv1(n+1-j,R(j,j),rw) 78 | c apply rotations to R 79 | call cqrqh(n+1-j,n-j,R(j,j+1),ldr,rw,R(j+1,j)) 80 | c zero spike. 81 | do l = j+1,n 82 | R(l,j) = 0e0 83 | end do 84 | end if 85 | end subroutine 86 | -------------------------------------------------------------------------------- /src/qrupdate/cgqvec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cgqvec(m,n,Q,ldq,u) 22 | c purpose: given an unitary m-by-n matrix Q, n < m, generates 23 | c a vector u such that Q'*u = 0 and norm(u) = 1. 24 | c arguments: 25 | c m (in) number of rows of matrix Q. 26 | c n (in) number of columns of matrix Q. 27 | c Q (in) the unitary matrix Q. 28 | c ldq (in) leading dimension of Q. 29 | c u (out) the generated vector. 30 | c 31 | integer m,n,ldq 32 | complex Q(ldq,*),u(*) 33 | external cdotu,caxpy,scnrm2,csscal 34 | complex cdotu 35 | real scnrm2,r 36 | integer info,i,j 37 | c quick return if possible. 38 | if (m == 0) return 39 | if (n == 0) then 40 | u(1) = 1e0 41 | do i = 2,m 42 | u(i) = 0e0 43 | end do 44 | return 45 | end if 46 | c check arguments. 47 | info = 0 48 | if (m < 0) then 49 | info = 1 50 | else if (n < 0) then 51 | info = 2 52 | else if (ldq < m) then 53 | info = 4 54 | end if 55 | if (info /= 0) then 56 | call xerbla('CGQVEC',info) 57 | return 58 | end if 59 | 60 | j = 1 61 | 10 continue 62 | c probe j-th canonical unit vector. 63 | do i = 1,m 64 | u(i) = 0e0 65 | end do 66 | u(j) = 1e0 67 | c form u - Q*Q'*u 68 | do i = 1,n 69 | r = cdotu(m,Q(1,i),1,u,1) 70 | call caxpy(m,-r,Q(1,i),1,u,1) 71 | end do 72 | r = scnrm2(m,u,1) 73 | if (r == 0e0) then 74 | j = j + 1 75 | if (j > n) then 76 | c this is fatal, and in theory, it can't happen. 77 | stop 'fatal: impossible condition in CGQVEC' 78 | else 79 | j = j + 1 80 | goto 10 81 | end if 82 | end if 83 | call csscal(m,1e0/r,u,1) 84 | end subroutine 85 | -------------------------------------------------------------------------------- /src/qrupdate/cqhqr.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cqhqr(m,n,R,ldr,c,s) 22 | c purpose: given an m-by-n upper Hessenberg matrix R, this 23 | c subroutine updates R to upper trapezoidal form 24 | c using min(m-1,n) Givens rotations. 25 | c (complex version) 26 | c arguments: 27 | c m (in) number of rows of the matrix R 28 | c n (in) number of columns of the matrix R 29 | c R (io) on entry, the upper Hessenberg matrix R 30 | c on exit, the updated upper trapezoidal matrix 31 | c ldr (in) leading dimension of R, >= m 32 | c c(out) rotation cosines, size at least min(m-1,n) 33 | c s(out) rotation sines, size at least min(m-1,n) 34 | c 35 | integer m,n,ldr 36 | complex R(ldr,*),s(*) 37 | real c(*) 38 | external xerbla,clartg 39 | complex t 40 | integer info,i,ii,j 41 | c quick return if possible. 42 | if (m == 0 .or. m == 1 .or. n == 0) return 43 | c check arguments. 44 | info = 0 45 | if (m < 0) then 46 | info = 1 47 | else if (n < 0) then 48 | info = 2 49 | else if (ldr < m) then 50 | info = 4 51 | end if 52 | if (info /= 0) then 53 | call xerbla('CQHQR',info) 54 | return 55 | end if 56 | do i = 1,n 57 | c apply stored rotations, column-wise 58 | t = R(1,i) 59 | ii = min(m,i) 60 | do j = 1,ii-1 61 | R(j,i) = c(j)*t + s(j)*R(j+1,i) 62 | t = c(j)*R(j+1,i) - conjg(s(j))*t 63 | end do 64 | if (ii < m) then 65 | c generate next rotation 66 | call clartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) 67 | R(ii+1,i) = 0e0 68 | else 69 | R(ii,i) = t 70 | end if 71 | end do 72 | end subroutine 73 | -------------------------------------------------------------------------------- /src/qrupdate/cqrdec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cqrdec(m,n,k,Q,ldq,R,ldr,j,rw) 22 | c purpose: updates a QR factorization after deleting 23 | c a column. 24 | c i.e., given an m-by-k unitary matrix Q, an k-by-n 25 | c upper trapezoidal matrix R and index j in the range 26 | c 1:n+1, this subroutine updates the matrix Q -> Q1 and 27 | c R -> R1 so that Q1 remains unitary, R1 is upper 28 | c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], 29 | c where A = Q*R. 30 | c (complex version) 31 | c arguments: 32 | c m (in) number of rows of the matrix Q. 33 | c n (in) number of columns of the matrix R. 34 | c k (in) number of columns of Q, and rows of R. Must be 35 | c either k = m (full Q) or k = n < m (economical form, 36 | c basis dimension will decrease). 37 | c Q (io) on entry, the unitary m-by-k matrix Q. 38 | c on exit, the updated matrix Q1. 39 | c ldq (in) leading dimension of Q. ldq >= m. 40 | c R (io) on entry, the original matrix R. 41 | c on exit, the updated matrix R1. 42 | c ldr (in) leading dimension of R. ldr >= k. 43 | c j (in) the position of the deleted column in R. 44 | c 1 <= j <= n. 45 | c rw (o) a real workspace vector of size k-j. 46 | c 47 | integer m,n,k,ldq,ldr,j 48 | complex Q(ldq,*),R(ldr,*) 49 | real rw(*) 50 | external xerbla,ccopy,cqhqr,cqrot 51 | integer info,i 52 | c quick return if possible. 53 | if (m == 0 .or. n == 0 .or. j == n) return 54 | c check arguments. 55 | info = 0 56 | if (m < 0) then 57 | info = 1 58 | else if (n < 0) then 59 | info = 2 60 | else if (k /= m .and. (k /= n .or. n >= m)) then 61 | info = 3 62 | else if (ldq < m) then 63 | info = 5 64 | else if (ldr < k) then 65 | info = 7 66 | else if (j < 1 .or. j > n+1) then 67 | info = 8 68 | end if 69 | if (info /= 0) then 70 | call xerbla('CQRDEC',info) 71 | return 72 | end if 73 | 74 | c delete the j-th column. 75 | do i = j,n-1 76 | call ccopy(k,R(1,i+1),1,R(1,i),1) 77 | end do 78 | c retriangularize. 79 | if (j < k) then 80 | call cqhqr(k+1-j,n-j,R(j,j),ldr,rw,R(1,n)) 81 | c apply rotations to Q. 82 | call cqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,rw,R(1,n)) 83 | end if 84 | end subroutine 85 | -------------------------------------------------------------------------------- /src/qrupdate/cqrder.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cqrder(m,n,Q,ldq,R,ldr,j,w,rw) 22 | c purpose: updates a QR factorization after deleting a row. 23 | c i.e., given an m-by-m unitary matrix Q, an m-by-n 24 | c upper trapezoidal matrix R and index j in the range 25 | c 1:m, this subroutine updates Q ->Q1 and an R -> R1 26 | c so that Q1 is again unitary, R1 upper trapezoidal, 27 | c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. 28 | c (complex version) 29 | c 30 | c arguments: 31 | c m (in) number of rows of the matrix Q. 32 | c n (in) number of columns of the matrix R. 33 | c Q (io) on entry, the unitary matrix Q. 34 | c on exit, the updated matrix Q1. 35 | c ldq (in) leading dimension of Q. ldq >= m. 36 | c R (io) on entry, the original matrix R. 37 | c on exit, the updated matrix R1. 38 | c ldr (in) leading dimension of R. ldr >= m. 39 | c j (in) the position of the deleted row. 40 | c w (out) a workspace vector of size m. 41 | c rw (out) a real workspace vector of size m. 42 | c 43 | integer m,n,j,ldq,ldr 44 | complex Q(ldq,*),R(ldr,*),w(*) 45 | real rw(*) 46 | external xerbla,ccopy,cqrtv1,cqrot,cqrqh 47 | integer info,i,k 48 | c quick return if possible 49 | if (m == 1) return 50 | c check arguments 51 | info = 0 52 | if (m < 1) then 53 | info = 1 54 | else if (j < 1 .or. j > m) then 55 | info = 7 56 | end if 57 | if (info /= 0) then 58 | call xerbla('CQRDER',info) 59 | return 60 | end if 61 | c eliminate Q(j,2:m). 62 | do k = 1,m 63 | w(k) = conjg(Q(j,k)) 64 | end do 65 | call cqrtv1(m,w,rw) 66 | c apply rotations to Q. 67 | call cqrot('B',m,m,Q,ldq,rw,w(2)) 68 | c form Q1. 69 | do k = 1,m-1 70 | if (j > 1) call ccopy(j-1,Q(1,k+1),1,Q(1,k),1) 71 | if (j < m) call ccopy(m-j,Q(j+1,k+1),1,Q(j,k),1) 72 | end do 73 | c apply rotations to R. 74 | call cqrqh(m,n,R,ldr,rw,w(2)) 75 | c form R1. 76 | do k = 1,n 77 | do i = 1,m-1 78 | R(i,k) = R(i+1,k) 79 | end do 80 | end do 81 | end subroutine 82 | -------------------------------------------------------------------------------- /src/qrupdate/cqrot.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cqrot(dir,m,n,Q,ldq,c,s) 22 | c purpose: Apply a sequence of inv. rotations from right 23 | c 24 | c arguments: 25 | c dir (in) if 'B' or 'b', rotations are applied from backwards 26 | c if 'F' or 'f', from forwards. 27 | c m (in) number of rows of matrix Q 28 | c n (in) number of columns of the matrix Q 29 | c Q (io) on entry, the matrix Q 30 | c on exit, the updated matrix Q1 31 | c ldq (in) the leading dimension of Q 32 | c c (in) n-1 rotation cosines 33 | c s (in) n-1 rotation sines 34 | c 35 | character dir 36 | integer m,n,ldq 37 | complex Q(ldq,*),s(*) 38 | real c(*) 39 | external crot,lsame 40 | logical lsame,fwd 41 | integer info,i 42 | c quick return if possible 43 | if (m == 0 .or. n == 0 .or. n == 1) return 44 | c check arguments. 45 | info = 0 46 | fwd = lsame(dir,'F') 47 | if (.not.(fwd .or. lsame(dir,'B'))) then 48 | info = 1 49 | else if (m < 0) then 50 | info = 2 51 | else if (n < 0) then 52 | info = 3 53 | else if (ldq < m) then 54 | info = 5 55 | end if 56 | if (info /= 0) then 57 | call xerbla('CQROT',info) 58 | return 59 | end if 60 | 61 | if (fwd) then 62 | do i = 1,n-1 63 | call crot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) 64 | end do 65 | else 66 | do i = n-1,1,-1 67 | call crot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) 68 | end do 69 | end if 70 | end subroutine 71 | -------------------------------------------------------------------------------- /src/qrupdate/cqrqh.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cqrqh(m,n,R,ldr,c,s) 22 | c purpose: brings an upper trapezoidal matrix R into upper 23 | c Hessenberg form using min(m-1,n) Givens rotations. 24 | c (complex version) 25 | c arguments: 26 | c m (in) number of rows of the matrix R 27 | c n (in) number of columns of the matrix R 28 | c R (io) on entry, the upper Hessenberg matrix R 29 | c on exit, the updated upper trapezoidal matrix 30 | c ldr (in) leading dimension of R, >= m 31 | c c(in) rotation cosines, size at least min(m-1,n) 32 | c s(in) rotation sines, size at least min(m-1,n) 33 | c 34 | integer m,n,ldr 35 | complex R(ldr,*),s(*) 36 | real c(*) 37 | external xerbla 38 | complex t 39 | integer info,i,ii,j 40 | c quick return if possible. 41 | if (m == 0 .or. m == 1 .or. n == 0) return 42 | c check arguments. 43 | info = 0 44 | if (m < 0) then 45 | info = 1 46 | else if (n < 0) then 47 | info = 2 48 | else if (ldr < m) then 49 | info = 4 50 | end if 51 | if (info /= 0) then 52 | call xerbla('CQRQH',info) 53 | return 54 | end if 55 | do i = 1,n 56 | c apply stored rotations, column-wise 57 | ii = min(m-1,i) 58 | t = R(ii+1,i) 59 | do j = ii,1,-1 60 | R(j+1,i) = c(j)*t - conjg(s(j))*R(j,i) 61 | t = c(j)*R(j,i) + s(j)*t 62 | end do 63 | R(1,i) = t 64 | end do 65 | end subroutine 66 | -------------------------------------------------------------------------------- /src/qrupdate/cqrtv1.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine cqrtv1(n,u,w) 22 | c purpose: generates a sequence of n-1 Givens rotations that 23 | c eliminate all but the first element of a vector u. 24 | c arguments: 25 | c n (in) the length of the vector u 26 | c u (io) on entry, the vector u. 27 | c on exit, u(2:n) contains the rotation sines, u(1) 28 | c contains the remaining element. 29 | c w (o) on exit, w contains the rotation cosines. 30 | c 31 | integer n 32 | complex u(*) 33 | real w(*) 34 | external clartg 35 | complex rr,t 36 | integer i 37 | c quick return if possible. 38 | if (n <= 0) return 39 | rr = u(n) 40 | do i = n-1,1,-1 41 | call clartg(u(i),rr,w(i),u(i+1),t) 42 | rr = t 43 | end do 44 | u(1) = rr 45 | end subroutine 46 | -------------------------------------------------------------------------------- /src/qrupdate/dch1dn.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dch1dn(n,R,ldr,u,w,info) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a hermitian positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine downdates R -> R1 so that 25 | c R1'*R1 = A - u*u' 26 | c (real version) 27 | c arguments: 28 | c n (in) the order of matrix R 29 | c R (io) on entry, the upper triangular matrix R 30 | c on exit, the updated matrix R1 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c u (io) the vector determining the rank-1 update 33 | c on exit, u contains the reflector sines 34 | c used to transform R to R1. 35 | c w (out) cosine parts of reflectors. 36 | c 37 | c info (out) on exit, error code: 38 | c info = 0: success. 39 | c info = 1: update violates positive-definiteness. 40 | c info = 2: R is singular. 41 | c 42 | integer n,ldr 43 | double precision R(ldr,*),u(*),w(*) 44 | integer info 45 | external dtrsv,dlartg,dnrm2 46 | double precision dnrm2,rho,rr,ui,t 47 | integer i,j 48 | 49 | c quick return if possible. 50 | if (n == 0) return 51 | c check arguments. 52 | info = 0 53 | if (n < 0) then 54 | info = -1 55 | else if (ldr < n) then 56 | info = -3 57 | end if 58 | if (info /= 0) then 59 | call xerbla('DCH1DN',-info) 60 | return 61 | end if 62 | 63 | c check for singularity of R. 64 | do i = 1,n 65 | if (R(i,i) == 0d0) goto 20 66 | end do 67 | c form R' \ u 68 | call dtrsv('U','T','N',n,R,ldr,u,1) 69 | rho = dnrm2(n,u,1) 70 | c check positive definiteness 71 | rho = 1 - rho**2 72 | if (rho <= 0d0) goto 10 73 | rho = sqrt(rho) 74 | c eliminate R' \ u 75 | do i = n,1,-1 76 | ui = u(i) 77 | c generate next rotation 78 | call dlartg(rho,ui,w(i),u(i),rr) 79 | rho = rr 80 | end do 81 | c apply rotations 82 | do i = n,1,-1 83 | ui = 0d0 84 | do j = i,1,-1 85 | t = w(j)*ui + u(j)*R(j,i) 86 | R(j,i) = w(j)*R(j,i) - u(j)*ui 87 | ui = t 88 | end do 89 | end do 90 | 91 | c normal return 92 | return 93 | c error returns 94 | 10 info = 1 95 | return 96 | 20 info = 2 97 | return 98 | end subroutine 99 | -------------------------------------------------------------------------------- /src/qrupdate/dch1up.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dch1up(n,R,ldr,u,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A + u*u' 26 | c (real version) 27 | c arguments: 28 | c n (in) the order of matrix R 29 | c R (io) on entry, the upper triangular matrix R 30 | c on exit, the updated matrix R1 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c u (io) the vector determining the rank-1 update 33 | c on exit, u contains the rotation sines 34 | c used to transform R to R1. 35 | c w (out) cosine parts of rotations. 36 | c 37 | integer n,ldr 38 | double precision R(ldr,*),u(*) 39 | double precision w(*) 40 | external dlartg 41 | double precision rr,ui,t 42 | integer i,j 43 | 44 | do i = 1,n 45 | c apply stored rotations, column-wise 46 | ui = u(i) 47 | do j = 1,i-1 48 | t = w(j)*R(j,i) + u(j)*ui 49 | ui = w(j)*ui - u(j)*R(j,i) 50 | R(j,i) = t 51 | end do 52 | c generate next rotation 53 | call dlartg(R(i,i),ui,w(i),u(i),rr) 54 | R(i,i) = rr 55 | end do 56 | end subroutine 57 | 58 | -------------------------------------------------------------------------------- /src/qrupdate/dchdex.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dchdex(n,R,ldr,j,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(jj,jj), where jj = [1:j-1,j+1:n+1]. 26 | c (real version) 27 | c arguments: 28 | c n (in) the order of matrix R. 29 | c R (io) on entry, the original upper trapezoidal matrix R. 30 | c on exit, the updated matrix R1. 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c j (in) the position of the deleted row/column. 33 | c w (out) a workspace vector of size n. 34 | c 35 | integer n,ldr,j 36 | double precision R(ldr,*),w(*) 37 | integer info,i 38 | external xerbla,dcopy,dqhqr 39 | 40 | c quick return if possible 41 | if (n == 1) return 42 | 43 | c check arguments 44 | info = 0 45 | if (n < 0) then 46 | info = 1 47 | else if (j < 1 .or. j > n) then 48 | info = 4 49 | end if 50 | if (info /= 0) then 51 | call xerbla('DCHDEX',info) 52 | return 53 | end if 54 | 55 | c delete the j-th column. 56 | do i = j,n-1 57 | call dcopy(n,R(1,i+1),1,R(1,i),1) 58 | end do 59 | c retriangularize. 60 | if (j < n) then 61 | call dqhqr(n+1-j,n-j,R(j,j),ldr,w,R(1,n)) 62 | end if 63 | end subroutine 64 | -------------------------------------------------------------------------------- /src/qrupdate/dchshx.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dchshx(n,R,ldr,i,j,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(p,p), where p is the permutation 26 | c [1:i-1,shift(i:j,-1),j+1:n] if i < j or 27 | c [1:j-1,shift(j:i,+1),i+1:n] if j < i. 28 | c (real version) 29 | c arguments: 30 | c n (in) the order of matrix R 31 | c R (io) on entry, the upper triangular matrix R 32 | c on exit, the updated matrix R1 33 | c ldr (in) leading dimension of R. ldr >= n. 34 | c i (in) the first index determining the range (see above). 35 | c j (in) the second index determining the range (see above). 36 | c w (o) a workspace vector of size 2*n. 37 | c 38 | integer n,ldr,i,j 39 | double precision R(ldr,*),w(*) 40 | external xerbla,dcopy,dqrtv1,dqrqh,dqhqr 41 | integer info,l 42 | c quick return if possible. 43 | if (n == 0 .or. n == 1) return 44 | info = 0 45 | c check arguments. 46 | if (n < 0) then 47 | info = 1 48 | else if (i < 1 .or. i > n) then 49 | info = 4 50 | else if (j < 1 .or. j > n) then 51 | info = 5 52 | end if 53 | if (info /= 0) then 54 | call xerbla('DCHSHX',info) 55 | return 56 | end if 57 | 58 | if (i < j) then 59 | c shift columns 60 | call dcopy(n,R(1,i),1,w,1) 61 | do l = i,j-1 62 | call dcopy(n,R(1,l+1),1,R(1,l),1) 63 | end do 64 | call dcopy(n,w,1,R(1,j),1) 65 | c retriangularize 66 | call dqhqr(n+1-i,n+1-i,R(i,i),ldr,w(n+1),w) 67 | else if (j < i) then 68 | c shift columns 69 | call dcopy(n,R(1,i),1,w,1) 70 | do l = i,j+1,-1 71 | call dcopy(n,R(1,l-1),1,R(1,l),1) 72 | end do 73 | call dcopy(n,w,1,R(1,j),1) 74 | c eliminate the introduced spike. 75 | call dqrtv1(n+1-j,R(j,j),w(n+1)) 76 | c apply rotations to R 77 | call dqrqh(n+1-j,n-j,R(j,j+1),ldr,w(n+1),R(j+1,j)) 78 | c zero spike. 79 | do l = j+1,n 80 | R(l,j) = 0d0 81 | end do 82 | end if 83 | end subroutine 84 | -------------------------------------------------------------------------------- /src/qrupdate/dgqvec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dgqvec(m,n,Q,ldq,u) 22 | c purpose: given an orthogonal m-by-n matrix Q, n < m, generates 23 | c a vector u such that Q'*u = 0 and norm(u) = 1. 24 | c arguments: 25 | c m (in) number of rows of matrix Q. 26 | c n (in) number of columns of matrix Q. 27 | c Q (in) the orthogonal matrix Q. 28 | c ldq (in) leading dimension of Q. 29 | c u (out) the generated vector. 30 | c 31 | integer m,n,ldq 32 | double precision Q(ldq,*),u(*) 33 | external ddot,daxpy,dnrm2,dscal 34 | double precision ddot,dnrm2,r 35 | integer info,i,j 36 | c quick return if possible. 37 | if (m == 0) return 38 | if (n == 0) then 39 | u(1) = 1d0 40 | do i = 2,m 41 | u(i) = 0d0 42 | end do 43 | return 44 | end if 45 | c check arguments. 46 | info = 0 47 | if (m < 0) then 48 | info = 1 49 | else if (n < 0) then 50 | info = 2 51 | else if (ldq < m) then 52 | info = 4 53 | end if 54 | if (info /= 0) then 55 | call xerbla('DGQVEC',info) 56 | return 57 | end if 58 | 59 | j = 1 60 | 10 continue 61 | c probe j-th canonical unit vector. 62 | do i = 1,m 63 | u(i) = 0d0 64 | end do 65 | u(j) = 1d0 66 | c form u - Q*Q'*u 67 | do i = 1,n 68 | r = ddot(m,Q(1,i),1,u,1) 69 | call daxpy(m,-r,Q(1,i),1,u,1) 70 | end do 71 | r = dnrm2(m,u,1) 72 | if (r == 0d0) then 73 | j = j + 1 74 | if (j > n) then 75 | c this is fatal, and in theory, it can't happen. 76 | stop 'fatal: impossible condition in DGQVEC' 77 | else 78 | j = j + 1 79 | goto 10 80 | end if 81 | end if 82 | call dscal(m,1d0/r,u,1) 83 | end subroutine 84 | -------------------------------------------------------------------------------- /src/qrupdate/dqhqr.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dqhqr(m,n,R,ldr,c,s) 22 | c purpose: given an m-by-n upper Hessenberg matrix R, this 23 | c subroutine updates R to upper trapezoidal form 24 | c using min(m-1,n) Givens rotations. 25 | c (real version) 26 | c arguments: 27 | c m (in) number of rows of the matrix R 28 | c n (in) number of columns of the matrix R 29 | c R (io) on entry, the upper Hessenberg matrix R 30 | c on exit, the updated upper trapezoidal matrix 31 | c ldr (in) leading dimension of R, >= m 32 | c c(out) rotation cosines, size at least min(m-1,n) 33 | c s(out) rotation sines, size at least min(m-1,n) 34 | c 35 | integer m,n,ldr 36 | double precision R(ldr,*),c(*),s(*) 37 | external xerbla,dlartg 38 | double precision t 39 | integer info,i,ii,j 40 | c quick return if possible. 41 | if (m == 0 .or. m == 1 .or. n == 0) return 42 | c check arguments. 43 | info = 0 44 | if (m < 0) then 45 | info = 1 46 | else if (n < 0) then 47 | info = 2 48 | else if (ldr < m) then 49 | info = 4 50 | end if 51 | if (info /= 0) then 52 | call xerbla('DQHQR',info) 53 | return 54 | end if 55 | do i = 1,n 56 | c apply stored rotations, column-wise 57 | t = R(1,i) 58 | ii = min(m,i) 59 | do j = 1,ii-1 60 | R(j,i) = c(j)*t + s(j)*R(j+1,i) 61 | t = c(j)*R(j+1,i) - s(j)*t 62 | end do 63 | if (ii < m) then 64 | c generate next rotation 65 | call dlartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) 66 | R(ii+1,i) = 0d0 67 | else 68 | R(ii,i) = t 69 | end if 70 | end do 71 | end subroutine 72 | -------------------------------------------------------------------------------- /src/qrupdate/dqrdec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dqrdec(m,n,k,Q,ldq,R,ldr,j,w) 22 | c purpose: updates a QR factorization after deleting 23 | c a column. 24 | c i.e., given an m-by-k orthogonal matrix Q, an k-by-n 25 | c upper trapezoidal matrix R and index j in the range 26 | c 1:n+1, this subroutine updates the matrix Q -> Q1 and 27 | c R -> R1 so that Q1 remains orthogonal, R1 is upper 28 | c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], 29 | c where A = Q*R. 30 | c (real version) 31 | c arguments: 32 | c m (in) number of rows of the matrix Q. 33 | c n (in) number of columns of the matrix R. 34 | c k (in) number of columns of Q, and rows of R. Must be 35 | c either k = m (full Q) or k = n < m (economical form, 36 | c basis dimension will decrease). 37 | c Q (io) on entry, the unitary m-by-k matrix Q. 38 | c on exit, the updated matrix Q1. 39 | c ldq (in) leading dimension of Q. ldq >= m. 40 | c R (io) on entry, the original matrix R. 41 | c on exit, the updated matrix R1. 42 | c ldr (in) leading dimension of R. ldr >= k. 43 | c j (in) the position of the deleted column in R. 44 | c 1 <= j <= n. 45 | c w (o) a workspace vector of size k-j. 46 | c 47 | integer m,n,k,ldq,ldr,j 48 | double precision Q(ldq,*),R(ldr,*),w(*) 49 | external xerbla,dcopy,dqhqr,dqrot 50 | integer info,i 51 | c quick return if possible. 52 | if (m == 0 .or. n == 0 .or. j == n) return 53 | c check arguments. 54 | info = 0 55 | if (m < 0) then 56 | info = 1 57 | else if (n < 0) then 58 | info = 2 59 | else if (k /= m .and. (k /= n .or. n >= m)) then 60 | info = 3 61 | else if (ldq < m) then 62 | info = 5 63 | else if (ldr < k) then 64 | info = 7 65 | else if (j < 1 .or. j > n+1) then 66 | info = 8 67 | end if 68 | if (info /= 0) then 69 | call xerbla('DQRDEC',info) 70 | return 71 | end if 72 | 73 | c delete the j-th column. 74 | do i = j,n-1 75 | call dcopy(k,R(1,i+1),1,R(1,i),1) 76 | end do 77 | c retriangularize. 78 | if (j < k) then 79 | call dqhqr(k+1-j,n-j,R(j,j),ldr,w,R(1,n)) 80 | c apply rotations to Q. 81 | call dqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,w,R(1,n)) 82 | end if 83 | end subroutine 84 | -------------------------------------------------------------------------------- /src/qrupdate/dqrder.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dqrder(m,n,Q,ldq,R,ldr,j,w) 22 | c purpose: updates a QR factorization after deleting a row. 23 | c i.e., given an m-by-m orthogonal matrix Q, an m-by-n 24 | c upper trapezoidal matrix R and index j in the range 25 | c 1:m, this subroutine updates Q ->Q1 and an R -> R1 26 | c so that Q1 is again orthogonal, R1 upper trapezoidal, 27 | c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. 28 | c (real version) 29 | c 30 | c arguments: 31 | c m (in) number of rows of the matrix Q. 32 | c n (in) number of columns of the matrix R. 33 | c Q (io) on entry, the orthogonal matrix Q. 34 | c on exit, the updated matrix Q1. 35 | c ldq (in) leading dimension of Q. ldq >= m. 36 | c R (io) on entry, the original matrix R. 37 | c on exit, the updated matrix R1. 38 | c ldr (in) leading dimension of R. ldr >= m. 39 | c j (in) the position of the deleted row. 40 | c w (out) a workspace vector of size 2*m. 41 | c 42 | integer m,n,j,ldq,ldr 43 | double precision Q(ldq,*),R(ldr,*),w(*) 44 | external xerbla,dcopy,dqrtv1,dqrot,dqrqh 45 | integer info,i,k 46 | c quick return if possible 47 | if (m == 1) return 48 | c check arguments 49 | info = 0 50 | if (m < 1) then 51 | info = 1 52 | else if (j < 1 .or. j > m) then 53 | info = 7 54 | end if 55 | if (info /= 0) then 56 | call xerbla('DQRDER',info) 57 | return 58 | end if 59 | c eliminate Q(j,2:m). 60 | call dcopy(m,Q(j,1),ldq,w,1) 61 | call dqrtv1(m,w,w(m+1)) 62 | c apply rotations to Q. 63 | call dqrot('B',m,m,Q,ldq,w(m+1),w(2)) 64 | c form Q1. 65 | do k = 1,m-1 66 | if (j > 1) call dcopy(j-1,Q(1,k+1),1,Q(1,k),1) 67 | if (j < m) call dcopy(m-j,Q(j+1,k+1),1,Q(j,k),1) 68 | end do 69 | c apply rotations to R. 70 | call dqrqh(m,n,R,ldr,w(m+1),w(2)) 71 | c form R1. 72 | do k = 1,n 73 | do i = 1,m-1 74 | R(i,k) = R(i+1,k) 75 | end do 76 | end do 77 | end subroutine 78 | -------------------------------------------------------------------------------- /src/qrupdate/dqrot.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dqrot(dir,m,n,Q,ldq,c,s) 22 | c purpose: Apply a sequence of inv. rotations from right 23 | c 24 | c arguments: 25 | c dir (in) if 'B' or 'b', rotations are applied from backwards 26 | c if 'F' or 'f', from forwards. 27 | c m (in) number of rows of matrix Q 28 | c n (in) number of columns of the matrix Q 29 | c Q (io) on entry, the matrix Q 30 | c on exit, the updated matrix Q1 31 | c ldq (in) the leading dimension of Q 32 | c c (in) n-1 rotation cosines 33 | c s (in) n-1 rotation sines 34 | c 35 | character dir 36 | integer m,n,ldq 37 | double precision Q(ldq,*),c(*),s(*) 38 | external drot,lsame 39 | logical lsame,fwd 40 | integer info,i 41 | c quick return if possible 42 | if (m == 0 .or. n == 0 .or. n == 1) return 43 | c check arguments. 44 | info = 0 45 | fwd = lsame(dir,'F') 46 | if (.not.(fwd .or. lsame(dir,'B'))) then 47 | info = 1 48 | else if (m < 0) then 49 | info = 2 50 | else if (n < 0) then 51 | info = 3 52 | else if (ldq < m) then 53 | info = 5 54 | end if 55 | if (info /= 0) then 56 | call xerbla('DQROT',info) 57 | return 58 | end if 59 | 60 | if (fwd) then 61 | do i = 1,n-1 62 | call drot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) 63 | end do 64 | else 65 | do i = n-1,1,-1 66 | call drot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) 67 | end do 68 | end if 69 | end subroutine 70 | -------------------------------------------------------------------------------- /src/qrupdate/dqrqh.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dqrqh(m,n,R,ldr,c,s) 22 | c purpose: brings an upper trapezoidal matrix R into upper 23 | c Hessenberg form using min(m-1,n) Givens rotations. 24 | c (real version) 25 | c arguments: 26 | c m (in) number of rows of the matrix R 27 | c n (in) number of columns of the matrix R 28 | c R (io) on entry, the upper Hessenberg matrix R 29 | c on exit, the updated upper trapezoidal matrix 30 | c ldr (in) leading dimension of R, >= m 31 | c c(in) rotation cosines, size at least min(m-1,n) 32 | c s(in) rotation sines, size at least min(m-1,n) 33 | c 34 | integer m,n,ldr 35 | double precision R(ldr,*),c(*),s(*) 36 | external xerbla 37 | double precision t 38 | integer info,i,ii,j 39 | c quick return if possible. 40 | if (m == 0 .or. m == 1 .or. n == 0) return 41 | c check arguments. 42 | info = 0 43 | if (m < 0) then 44 | info = 1 45 | else if (n < 0) then 46 | info = 2 47 | else if (ldr < m) then 48 | info = 4 49 | end if 50 | if (info /= 0) then 51 | call xerbla('DQRQH',info) 52 | return 53 | end if 54 | do i = 1,n 55 | ii = min(m-1,i) 56 | c apply stored rotations, column-wise 57 | t = R(ii+1,i) 58 | do j = ii,1,-1 59 | R(j+1,i) = c(j)*t - s(j)*R(j,i) 60 | t = c(j)*R(j,i) + s(j)*t 61 | end do 62 | R(1,i) = t 63 | end do 64 | end subroutine 65 | -------------------------------------------------------------------------------- /src/qrupdate/dqrtv1.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine dqrtv1(n,u,w) 22 | c purpose: generates a sequence of n-1 Givens rotations that 23 | c eliminate all but the first element of a vector u. 24 | c arguments: 25 | c n (in) the length of the vector u 26 | c u (io) on entry, the vector u. 27 | c on exit, u(2:n) contains the rotation sines, u(1) 28 | c contains the remaining element. 29 | c w (o) on exit, w contains the rotation cosines. 30 | c 31 | integer n 32 | double precision u(*),w(*) 33 | external dlartg 34 | double precision rr,t 35 | integer i 36 | c quick return if possible. 37 | if (n <= 0) return 38 | rr = u(n) 39 | do i = n-1,1,-1 40 | call dlartg(u(i),rr,w(i),u(i+1),t) 41 | rr = t 42 | end do 43 | u(1) = rr 44 | end subroutine 45 | -------------------------------------------------------------------------------- /src/qrupdate/sch1dn.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sch1dn(n,R,ldr,u,w,info) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a hermitian positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine downdates R -> R1 so that 25 | c R1'*R1 = A - u*u' 26 | c (real version) 27 | c arguments: 28 | c n (in) the order of matrix R 29 | c R (io) on entry, the upper triangular matrix R 30 | c on exit, the updated matrix R1 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c u (io) the vector determining the rank-1 update 33 | c on exit, u contains the reflector sines 34 | c used to transform R to R1. 35 | c w (out) cosine parts of reflectors. 36 | c 37 | c info (out) on exit, error code: 38 | c info = 0: success. 39 | c info = 1: update violates positive-definiteness. 40 | c info = 2: R is singular. 41 | c 42 | integer n,ldr 43 | real R(ldr,*),u(*),w(*) 44 | integer info 45 | external strsv,slartg,snrm2 46 | real snrm2,rho,rr,ui,t 47 | integer i,j 48 | 49 | c quick return if possible. 50 | if (n == 0) return 51 | c check arguments. 52 | info = 0 53 | if (n < 0) then 54 | info = -1 55 | else if (ldr < n) then 56 | info = -3 57 | end if 58 | if (info /= 0) then 59 | call xerbla('SCH1DN',-info) 60 | return 61 | end if 62 | 63 | c check for singularity of R. 64 | do i = 1,n 65 | if (R(i,i) == 0e0) goto 20 66 | end do 67 | c form R' \ u 68 | call strsv('U','T','N',n,R,ldr,u,1) 69 | rho = snrm2(n,u,1) 70 | c check positive definiteness 71 | rho = 1 - rho**2 72 | if (rho <= 0e0) goto 10 73 | rho = sqrt(rho) 74 | c eliminate R' \ u 75 | do i = n,1,-1 76 | ui = u(i) 77 | c generate next rotation 78 | call slartg(rho,ui,w(i),u(i),rr) 79 | rho = rr 80 | end do 81 | c apply rotations 82 | do i = n,1,-1 83 | ui = 0e0 84 | do j = i,1,-1 85 | t = w(j)*ui + u(j)*R(j,i) 86 | R(j,i) = w(j)*R(j,i) - u(j)*ui 87 | ui = t 88 | end do 89 | end do 90 | 91 | c normal return 92 | return 93 | c error returns 94 | 10 info = 1 95 | return 96 | 20 info = 2 97 | return 98 | end subroutine 99 | -------------------------------------------------------------------------------- /src/qrupdate/sch1up.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sch1up(n,R,ldr,u,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A + u*u' 26 | c (real version) 27 | c arguments: 28 | c n (in) the order of matrix R 29 | c R (io) on entry, the upper triangular matrix R 30 | c on exit, the updated matrix R1 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c u (io) the vector determining the rank-1 update 33 | c on exit, u contains the rotation sines 34 | c used to transform R to R1. 35 | c w (out) cosine parts of rotations. 36 | c 37 | integer n,ldr 38 | real R(ldr,*),u(*) 39 | real w(*) 40 | external slartg 41 | real rr,ui,t 42 | integer i,j 43 | 44 | do i = 1,n 45 | c apply stored rotations, column-wise 46 | ui = u(i) 47 | do j = 1,i-1 48 | t = w(j)*R(j,i) + u(j)*ui 49 | ui = w(j)*ui - u(j)*R(j,i) 50 | R(j,i) = t 51 | end do 52 | c generate next rotation 53 | call slartg(R(i,i),ui,w(i),u(i),rr) 54 | R(i,i) = rr 55 | end do 56 | end subroutine 57 | 58 | -------------------------------------------------------------------------------- /src/qrupdate/schdex.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine schdex(n,R,ldr,j,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(jj,jj), where jj = [1:j-1,j+1:n+1]. 26 | c (real version) 27 | c arguments: 28 | c n (in) the order of matrix R. 29 | c R (io) on entry, the original upper trapezoidal matrix R. 30 | c on exit, the updated matrix R1. 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c j (in) the position of the deleted row/column. 33 | c w (out) a workspace vector of size n. 34 | c 35 | integer n,ldr,j 36 | real R(ldr,*),w(*) 37 | integer info,i 38 | external xerbla,scopy,sqhqr 39 | 40 | c quick return if possible 41 | if (n == 1) return 42 | 43 | c check arguments 44 | info = 0 45 | if (n < 0) then 46 | info = 1 47 | else if (j < 1 .or. j > n) then 48 | info = 4 49 | end if 50 | if (info /= 0) then 51 | call xerbla('SCHDEX',info) 52 | return 53 | end if 54 | 55 | c delete the j-th column. 56 | do i = j,n-1 57 | call scopy(n,R(1,i+1),1,R(1,i),1) 58 | end do 59 | c retriangularize. 60 | if (j < n) then 61 | call sqhqr(n+1-j,n-j,R(j,j),ldr,w,R(1,n)) 62 | end if 63 | end subroutine 64 | -------------------------------------------------------------------------------- /src/qrupdate/schshx.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine schshx(n,R,ldr,i,j,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(p,p), where p is the permutation 26 | c [1:i-1,shift(i:j,-1),j+1:n] if i < j or 27 | c [1:j-1,shift(j:i,+1),i+1:n] if j < i. 28 | c (real version) 29 | c arguments: 30 | c n (in) the order of matrix R 31 | c R (io) on entry, the upper triangular matrix R 32 | c on exit, the updated matrix R1 33 | c ldr (in) leading dimension of R. ldr >= n. 34 | c i (in) the first index determining the range (see above). 35 | c j (in) the second index determining the range (see above). 36 | c w (o) a workspace vector of size 2*n. 37 | c 38 | integer n,ldr,i,j 39 | real R(ldr,*),w(*) 40 | external xerbla,scopy,sqrtv1,sqrqh,sqhqr 41 | integer info,l 42 | c quick return if possible. 43 | if (n == 0 .or. n == 1) return 44 | info = 0 45 | c check arguments. 46 | if (n < 0) then 47 | info = 1 48 | else if (i < 1 .or. i > n) then 49 | info = 4 50 | else if (j < 1 .or. j > n) then 51 | info = 5 52 | end if 53 | if (info /= 0) then 54 | call xerbla('SCHSHX',info) 55 | return 56 | end if 57 | 58 | if (i < j) then 59 | c shift columns 60 | call scopy(n,R(1,i),1,w,1) 61 | do l = i,j-1 62 | call scopy(n,R(1,l+1),1,R(1,l),1) 63 | end do 64 | call scopy(n,w,1,R(1,j),1) 65 | c retriangularize 66 | call sqhqr(n+1-i,n+1-i,R(i,i),ldr,w(n+1),w) 67 | else if (j < i) then 68 | c shift columns 69 | call scopy(n,R(1,i),1,w,1) 70 | do l = i,j+1,-1 71 | call scopy(n,R(1,l-1),1,R(1,l),1) 72 | end do 73 | call scopy(n,w,1,R(1,j),1) 74 | c eliminate the introduced spike. 75 | call sqrtv1(n+1-j,R(j,j),w(n+1)) 76 | c apply rotations to R 77 | call sqrqh(n+1-j,n-j,R(j,j+1),ldr,w(n+1),R(j+1,j)) 78 | c zero spike. 79 | do l = j+1,n 80 | R(l,j) = 0e0 81 | end do 82 | end if 83 | end subroutine 84 | -------------------------------------------------------------------------------- /src/qrupdate/sgqvec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sgqvec(m,n,Q,ldq,u) 22 | c purpose: given an orthogonal m-by-n matrix Q, n < m, generates 23 | c a vector u such that Q'*u = 0 and norm(u) = 1. 24 | c arguments: 25 | c m (in) number of rows of matrix Q. 26 | c n (in) number of columns of matrix Q. 27 | c Q (in) the orthogonal matrix Q. 28 | c ldq (in) leading dimension of Q. 29 | c u (out) the generated vector. 30 | c 31 | integer m,n,ldq 32 | real Q(ldq,*),u(*) 33 | external sdot,saxpy,snrm2,sscal 34 | real sdot,snrm2,r 35 | integer info,i,j 36 | c quick return if possible. 37 | if (m == 0) return 38 | if (n == 0) then 39 | u(1) = 1e0 40 | do i = 2,m 41 | u(i) = 0e0 42 | end do 43 | return 44 | end if 45 | c check arguments. 46 | info = 0 47 | if (m < 0) then 48 | info = 1 49 | else if (n < 0) then 50 | info = 2 51 | else if (ldq < m) then 52 | info = 4 53 | end if 54 | if (info /= 0) then 55 | call xerbla('SGQVEC',info) 56 | return 57 | end if 58 | 59 | j = 1 60 | 10 continue 61 | c probe j-th canonical unit vector. 62 | do i = 1,m 63 | u(i) = 0e0 64 | end do 65 | u(j) = 1e0 66 | c form u - Q*Q'*u 67 | do i = 1,n 68 | r = sdot(m,Q(1,i),1,u,1) 69 | call saxpy(m,-r,Q(1,i),1,u,1) 70 | end do 71 | r = snrm2(m,u,1) 72 | if (r == 0e0) then 73 | j = j + 1 74 | if (j > n) then 75 | c this is fatal, and in theory, it can't happen. 76 | stop 'fatal: impossible condition in DGQVEC' 77 | else 78 | j = j + 1 79 | goto 10 80 | end if 81 | end if 82 | call sscal(m,1e0/r,u,1) 83 | end subroutine 84 | -------------------------------------------------------------------------------- /src/qrupdate/sqhqr.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sqhqr(m,n,R,ldr,c,s) 22 | c purpose: given an m-by-n upper Hessenberg matrix R, this 23 | c subroutine updates R to upper trapezoidal form 24 | c using min(m-1,n) Givens rotations. 25 | c (real version) 26 | c arguments: 27 | c m (in) number of rows of the matrix R 28 | c n (in) number of columns of the matrix R 29 | c R (io) on entry, the upper Hessenberg matrix R 30 | c on exit, the updated upper trapezoidal matrix 31 | c ldr (in) leading dimension of R, >= m 32 | c c(out) rotation cosines, size at least min(m-1,n) 33 | c s(out) rotation sines, size at least min(m-1,n) 34 | c 35 | integer m,n,ldr 36 | real R(ldr,*),c(*),s(*) 37 | external xerbla,slartg 38 | real t 39 | integer info,i,ii,j 40 | c quick return if possible. 41 | if (m == 0 .or. m == 1 .or. n == 0) return 42 | c check arguments. 43 | info = 0 44 | if (m < 0) then 45 | info = 1 46 | else if (n < 0) then 47 | info = 2 48 | else if (ldr < m) then 49 | info = 4 50 | end if 51 | if (info /= 0) then 52 | call xerbla('SQHQR',info) 53 | return 54 | end if 55 | do i = 1,n 56 | c apply stored rotations, column-wise 57 | t = R(1,i) 58 | ii = min(m,i) 59 | do j = 1,ii-1 60 | R(j,i) = c(j)*t + s(j)*R(j+1,i) 61 | t = c(j)*R(j+1,i) - s(j)*t 62 | end do 63 | if (ii < m) then 64 | c generate next rotation 65 | call slartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) 66 | R(ii+1,i) = 0e0 67 | else 68 | R(ii,i) = t 69 | end if 70 | end do 71 | end subroutine 72 | -------------------------------------------------------------------------------- /src/qrupdate/sqrdec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sqrdec(m,n,k,Q,ldq,R,ldr,j,w) 22 | c purpose: updates a QR factorization after deleting 23 | c a column. 24 | c i.e., given an m-by-k orthogonal matrix Q, an k-by-n 25 | c upper trapezoidal matrix R and index j in the range 26 | c 1:n+1, this subroutine updates the matrix Q -> Q1 and 27 | c R -> R1 so that Q1 remains orthogonal, R1 is upper 28 | c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], 29 | c where A = Q*R. 30 | c (real version) 31 | c arguments: 32 | c m (in) number of rows of the matrix Q. 33 | c n (in) number of columns of the matrix R. 34 | c k (in) number of columns of Q, and rows of R. Must be 35 | c either k = m (full Q) or k = n < m (economical form, 36 | c basis dimension will decrease). 37 | c Q (io) on entry, the unitary m-by-k matrix Q. 38 | c on exit, the updated matrix Q1. 39 | c ldq (in) leading dimension of Q. ldq >= m. 40 | c R (io) on entry, the original matrix R. 41 | c on exit, the updated matrix R1. 42 | c ldr (in) leading dimension of R. ldr >= k. 43 | c j (in) the position of the deleted column in R. 44 | c 1 <= j <= n. 45 | c w (o) a workspace vector of size k-j. 46 | c 47 | integer m,n,k,ldq,ldr,j 48 | real Q(ldq,*),R(ldr,*),w(*) 49 | external xerbla,scopy,sqhqr,sqrot 50 | integer info,i 51 | c quick return if possible. 52 | if (m == 0 .or. n == 0 .or. j == n) return 53 | c check arguments. 54 | info = 0 55 | if (m < 0) then 56 | info = 1 57 | else if (n < 0) then 58 | info = 2 59 | else if (k /= m .and. (k /= n .or. n >= m)) then 60 | info = 3 61 | else if (ldq < m) then 62 | info = 5 63 | else if (ldr < k) then 64 | info = 7 65 | else if (j < 1 .or. j > n+1) then 66 | info = 8 67 | end if 68 | if (info /= 0) then 69 | call xerbla('SQRDEC',info) 70 | return 71 | end if 72 | 73 | c delete the j-th column. 74 | do i = j,n-1 75 | call scopy(k,R(1,i+1),1,R(1,i),1) 76 | end do 77 | c retriangularize. 78 | if (j < k) then 79 | call sqhqr(k+1-j,n-j,R(j,j),ldr,w,R(1,n)) 80 | c apply rotations to Q. 81 | call sqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,w,R(1,n)) 82 | end if 83 | end subroutine 84 | -------------------------------------------------------------------------------- /src/qrupdate/sqrder.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sqrder(m,n,Q,ldq,R,ldr,j,w) 22 | c purpose: updates a QR factorization after deleting a row. 23 | c i.e., given an m-by-m orthogonal matrix Q, an m-by-n 24 | c upper trapezoidal matrix R and index j in the range 25 | c 1:m, this subroutine updates Q ->Q1 and an R -> R1 26 | c so that Q1 is again orthogonal, R1 upper trapezoidal, 27 | c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. 28 | c (real version) 29 | c 30 | c arguments: 31 | c m (in) number of rows of the matrix Q. 32 | c n (in) number of columns of the matrix R. 33 | c Q (io) on entry, the orthogonal matrix Q. 34 | c on exit, the updated matrix Q1. 35 | c ldq (in) leading dimension of Q. ldq >= m. 36 | c R (io) on entry, the original matrix R. 37 | c on exit, the updated matrix R1. 38 | c ldr (in) leading dimension of R. ldr >= m. 39 | c j (in) the position of the deleted row. 40 | c w (out) a workspace vector of size 2*m. 41 | c 42 | integer m,n,j,ldq,ldr 43 | real Q(ldq,*),R(ldr,*),w(*) 44 | external xerbla,scopy,sqrtv1,sqrot,sqrqh 45 | integer info,i,k 46 | c quick return if possible 47 | if (m == 1) return 48 | c check arguments 49 | info = 0 50 | if (m < 1) then 51 | info = 1 52 | else if (j < 1 .or. j > m) then 53 | info = 7 54 | end if 55 | if (info /= 0) then 56 | call xerbla('SQRDER',info) 57 | return 58 | end if 59 | c eliminate Q(j,2:m). 60 | call scopy(m,Q(j,1),ldq,w,1) 61 | call sqrtv1(m,w,w(m+1)) 62 | c apply rotations to Q. 63 | call sqrot('B',m,m,Q,ldq,w(m+1),w(2)) 64 | c form Q1. 65 | do k = 1,m-1 66 | if (j > 1) call scopy(j-1,Q(1,k+1),1,Q(1,k),1) 67 | if (j < m) call scopy(m-j,Q(j+1,k+1),1,Q(j,k),1) 68 | end do 69 | c apply rotations to R. 70 | call sqrqh(m,n,R,ldr,w(m+1),w(2)) 71 | c form R1. 72 | do k = 1,n 73 | do i = 1,m-1 74 | R(i,k) = R(i+1,k) 75 | end do 76 | end do 77 | end subroutine 78 | -------------------------------------------------------------------------------- /src/qrupdate/sqrot.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sqrot(dir,m,n,Q,ldq,c,s) 22 | c purpose: Apply a sequence of inv. rotations from right 23 | c 24 | c arguments: 25 | c dir (in) if 'B' or 'b', rotations are applied from backwards 26 | c if 'F' or 'f', from forwards. 27 | c m (in) number of rows of matrix Q 28 | c n (in) number of columns of the matrix Q 29 | c Q (io) on entry, the matrix Q 30 | c on exit, the updated matrix Q1 31 | c ldq (in) the leading dimension of Q 32 | c c (in) n-1 rotation cosines 33 | c s (in) n-1 rotation sines 34 | c 35 | character dir 36 | integer m,n,ldq 37 | real Q(ldq,*),c(*),s(*) 38 | external srot,lsame 39 | logical lsame,fwd 40 | integer info,i 41 | c quick return if possible 42 | if (m == 0 .or. n == 0 .or. n == 1) return 43 | c check arguments. 44 | info = 0 45 | fwd = lsame(dir,'F') 46 | if (.not.(fwd .or. lsame(dir,'B'))) then 47 | info = 1 48 | else if (m < 0) then 49 | info = 2 50 | else if (n < 0) then 51 | info = 3 52 | else if (ldq < m) then 53 | info = 5 54 | end if 55 | if (info /= 0) then 56 | call xerbla('SQROT',info) 57 | return 58 | end if 59 | 60 | if (fwd) then 61 | do i = 1,n-1 62 | call srot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) 63 | end do 64 | else 65 | do i = n-1,1,-1 66 | call srot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) 67 | end do 68 | end if 69 | end subroutine 70 | -------------------------------------------------------------------------------- /src/qrupdate/sqrqh.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sqrqh(m,n,R,ldr,c,s) 22 | c purpose: brings an upper trapezoidal matrix R into upper 23 | c Hessenberg form using min(m-1,n) Givens rotations. 24 | c (real version) 25 | c arguments: 26 | c m (in) number of rows of the matrix R 27 | c n (in) number of columns of the matrix R 28 | c R (io) on entry, the upper Hessenberg matrix R 29 | c on exit, the updated upper trapezoidal matrix 30 | c ldr (in) leading dimension of R, >= m 31 | c c(in) rotation cosines, size at least min(m-1,n) 32 | c s(in) rotation sines, size at least min(m-1,n) 33 | c 34 | integer m,n,ldr 35 | real R(ldr,*),c(*),s(*) 36 | external xerbla 37 | real t 38 | integer info,i,ii,j 39 | c quick return if possible. 40 | if (m == 0 .or. m == 1 .or. n == 0) return 41 | c check arguments. 42 | info = 0 43 | if (m < 0) then 44 | info = 1 45 | else if (n < 0) then 46 | info = 2 47 | else if (ldr < m) then 48 | info = 4 49 | end if 50 | if (info /= 0) then 51 | call xerbla('SQRQH',info) 52 | return 53 | end if 54 | do i = 1,n 55 | ii = min(m-1,i) 56 | c apply stored rotations, column-wise 57 | t = R(ii+1,i) 58 | do j = ii,1,-1 59 | R(j+1,i) = c(j)*t - s(j)*R(j,i) 60 | t = c(j)*R(j,i) + s(j)*t 61 | end do 62 | R(1,i) = t 63 | end do 64 | end subroutine 65 | -------------------------------------------------------------------------------- /src/qrupdate/sqrtv1.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine sqrtv1(n,u,w) 22 | c purpose: generates a sequence of n-1 Givens rotations that 23 | c eliminate all but the first element of a vector u. 24 | c arguments: 25 | c n (in) the length of the vector u 26 | c u (io) on entry, the vector u. 27 | c on exit, u(2:n) contains the rotation sines, u(1) 28 | c contains the remaining element. 29 | c w (o) on exit, w contains the rotation cosines. 30 | c 31 | integer n 32 | real u(*),w(*) 33 | external slartg 34 | real rr,t 35 | integer i 36 | c quick return if possible. 37 | if (n <= 0) return 38 | rr = u(n) 39 | do i = n-1,1,-1 40 | call slartg(u(i),rr,w(i),u(i+1),t) 41 | rr = t 42 | end do 43 | u(1) = rr 44 | end subroutine 45 | -------------------------------------------------------------------------------- /src/qrupdate/zaxcpy.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zaxcpy(n,a,x,incx,y,incy) 22 | c purpose: constant times a conjugated vector plus a vector. 23 | c arguments: 24 | c n (in) vector length 25 | c a (in) complex factor 26 | c x (in) added vector 27 | c incx (in) x increments 28 | c y (io) accumulator vector 29 | c incy (in) y increments 30 | c 31 | integer n,incx,incy 32 | double complex a,x(*),y(*) 33 | integer i,ix,iy 34 | c quick return if possible. 35 | if (n <= 0) return 36 | if (incx /= 1 .or. incy /= 1) then 37 | c code for unequal increments or equal increments not equal to 1 38 | ix = 1 39 | iy = 1 40 | if (incx.lt.0) ix = (-n+1)*incx + 1 41 | if (incy.lt.0) iy = (-n+1)*incy + 1 42 | do i = 1,n 43 | y(iy) = y(iy) + a*conjg(x(ix)) 44 | ix = ix + incx 45 | iy = iy + incy 46 | end do 47 | else 48 | c code for both increments equal to 1 49 | do i = 1,n 50 | y(i) = y(i) + a*conjg(x(i)) 51 | end do 52 | end if 53 | end subroutine 54 | -------------------------------------------------------------------------------- /src/qrupdate/zch1up.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zch1up(n,R,ldr,u,w) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a hermitian positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A + u*u' 26 | c (complex version) 27 | c arguments: 28 | c n (in) the order of matrix R 29 | c R (io) on entry, the upper triangular matrix R 30 | c on exit, the updated matrix R1 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c u (io) the vector determining the rank-1 update 33 | c on exit, u contains the rotation sines 34 | c used to transform R to R1. 35 | c w (out) cosine parts of rotations. 36 | c 37 | integer n,ldr 38 | double complex R(ldr,*),u(*) 39 | double precision w(*) 40 | external zlartg 41 | double complex rr,ui,t 42 | integer i,j 43 | 44 | do i = 1,n 45 | c apply stored rotations, column-wise 46 | ui = conjg(u(i)) 47 | do j = 1,i-1 48 | t = w(j)*R(j,i) + u(j)*ui 49 | ui = w(j)*ui - conjg(u(j))*R(j,i) 50 | R(j,i) = t 51 | end do 52 | c generate next rotation 53 | call zlartg(R(i,i),ui,w(i),u(i),rr) 54 | R(i,i) = rr 55 | end do 56 | end subroutine 57 | 58 | -------------------------------------------------------------------------------- /src/qrupdate/zchdex.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zchdex(n,R,ldr,j,rw) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a hermitian positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(jj,jj), where jj = [1:j-1,j+1:n+1]. 26 | c (complex version) 27 | c arguments: 28 | c n (in) the order of matrix R. 29 | c R (io) on entry, the original upper trapezoidal matrix R. 30 | c on exit, the updated matrix R1. 31 | c ldr (in) leading dimension of R. ldr >= n. 32 | c j (in) the position of the deleted row/column. 33 | c rw (out) a real workspace vector of size n. 34 | c 35 | integer n,ldr,j 36 | double complex R(ldr,*) 37 | double precision rw(*) 38 | integer info,i 39 | external xerbla,zcopy,zqhqr 40 | 41 | c quick return if possible 42 | if (n == 1) return 43 | 44 | c check arguments 45 | info = 0 46 | if (n < 0) then 47 | info = 1 48 | else if (j < 1 .or. j > n) then 49 | info = 4 50 | end if 51 | if (info /= 0) then 52 | call xerbla('ZCHDEX',info) 53 | return 54 | end if 55 | 56 | c delete the j-th column. 57 | do i = j,n-1 58 | call zcopy(n,R(1,i+1),1,R(1,i),1) 59 | end do 60 | c retriangularize. 61 | if (j < n) then 62 | call zqhqr(n+1-j,n-j,R(j,j),ldr,rw,R(1,n)) 63 | end if 64 | end subroutine 65 | -------------------------------------------------------------------------------- /src/qrupdate/zchshx.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zchshx(n,R,ldr,i,j,w,rw) 22 | c purpose: given an upper triangular matrix R that is a Cholesky 23 | c factor of a symmetric positive definite matrix A, i.e. 24 | c A = R'*R, this subroutine updates R -> R1 so that 25 | c R1'*R1 = A(p,p), where p is the permutation 26 | c [1:i-1,shift(i:j,-1),j+1:n] if i < j or 27 | c [1:j-1,shift(j:i,+1),i+1:n] if j < i. 28 | c (complex version) 29 | c arguments: 30 | c n (in) the order of matrix R 31 | c R (io) on entry, the upper triangular matrix R 32 | c on exit, the updated matrix R1 33 | c ldr (in) leading dimension of R. ldr >= n. 34 | c i (in) the first index determining the range (see above). 35 | c j (in) the second index determining the range (see above). 36 | c w (o) a workspace vector of size n. 37 | c rw (o) a real workspace vector of size n. 38 | c 39 | integer n,ldr,i,j 40 | double complex R(ldr,*),w(*) 41 | double precision rw(*) 42 | external xerbla,zcopy,zqrtv1,zqrqh,zqhqr 43 | integer info,l 44 | c quick return if possible. 45 | if (n == 0 .or. n == 1) return 46 | info = 0 47 | c check arguments. 48 | if (n < 0) then 49 | info = 1 50 | else if (i < 1 .or. i > n) then 51 | info = 4 52 | else if (j < 1 .or. j > n) then 53 | info = 5 54 | end if 55 | if (info /= 0) then 56 | call xerbla('ZCHSHX',info) 57 | return 58 | end if 59 | 60 | if (i < j) then 61 | c shift columns 62 | call zcopy(n,R(1,i),1,w,1) 63 | do l = i,j-1 64 | call zcopy(n,R(1,l+1),1,R(1,l),1) 65 | end do 66 | call zcopy(n,w,1,R(1,j),1) 67 | c retriangularize 68 | call zqhqr(n+1-i,n+1-i,R(i,i),ldr,rw,w) 69 | else if (j < i) then 70 | c shift columns 71 | call zcopy(n,R(1,i),1,w,1) 72 | do l = i,j+1,-1 73 | call zcopy(n,R(1,l-1),1,R(1,l),1) 74 | end do 75 | call zcopy(n,w,1,R(1,j),1) 76 | c eliminate the introduced spike. 77 | call zqrtv1(n+1-j,R(j,j),rw) 78 | c apply rotations to R 79 | call zqrqh(n+1-j,n-j,R(j,j+1),ldr,rw,R(j+1,j)) 80 | c zero spike. 81 | do l = j+1,n 82 | R(l,j) = 0d0 83 | end do 84 | end if 85 | end subroutine 86 | -------------------------------------------------------------------------------- /src/qrupdate/zgqvec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zgqvec(m,n,Q,ldq,u) 22 | c purpose: given an unitary m-by-n matrix Q, n < m, generates 23 | c a vector u such that Q'*u = 0 and norm(u) = 1. 24 | c arguments: 25 | c m (in) number of rows of matrix Q. 26 | c n (in) number of columns of matrix Q. 27 | c Q (in) the unitary matrix Q. 28 | c ldq (in) leading dimension of Q. 29 | c u (out) the generated vector. 30 | c 31 | integer m,n,ldq 32 | double complex Q(ldq,*),u(*) 33 | external zdotu,zaxpy,dznrm2,zdscal 34 | real zdotu 35 | double precision dznrm2,r 36 | integer info,i,j 37 | c quick return if possible. 38 | if (m == 0) return 39 | if (n == 0) then 40 | u(1) = 1d0 41 | do i = 2,m 42 | u(i) = 0d0 43 | end do 44 | return 45 | end if 46 | c check arguments. 47 | info = 0 48 | if (m < 0) then 49 | info = 1 50 | else if (n < 0) then 51 | info = 2 52 | else if (ldq < m) then 53 | info = 4 54 | end if 55 | if (info /= 0) then 56 | call xerbla('ZGQVEC',info) 57 | return 58 | end if 59 | 60 | j = 1 61 | 10 continue 62 | c probe j-th canonical unit vector. 63 | do i = 1,m 64 | u(i) = 0d0 65 | end do 66 | u(j) = 1d0 67 | c form u - Q*Q'*u 68 | do i = 1,n 69 | r = zdotu(m,Q(1,i),1,u,1) 70 | call zaxpy(m,-r,Q(1,i),1,u,1) 71 | end do 72 | r = dznrm2(m,u,1) 73 | if (r == 0d0) then 74 | j = j + 1 75 | if (j > n) then 76 | c this is fatal, and in theory, it can't happen. 77 | stop 'fatal: impossible condition in ZGQVEC' 78 | else 79 | j = j + 1 80 | goto 10 81 | end if 82 | end if 83 | call zdscal(m,1d0/r,u,1) 84 | end subroutine 85 | -------------------------------------------------------------------------------- /src/qrupdate/zqhqr.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zqhqr(m,n,R,ldr,c,s) 22 | c purpose: given an m-by-n upper Hessenberg matrix R, this 23 | c subroutine updates R to upper trapezoidal form 24 | c using min(m-1,n) Givens rotations. 25 | c (complex version) 26 | c arguments: 27 | c m (in) number of rows of the matrix R 28 | c n (in) number of columns of the matrix R 29 | c R (io) on entry, the upper Hessenberg matrix R 30 | c on exit, the updated upper trapezoidal matrix 31 | c ldr (in) leading dimension of R, >= m 32 | c c(out) rotation cosines, size at least min(m-1,n) 33 | c s(out) rotation sines, size at least min(m-1,n) 34 | c 35 | integer m,n,ldr 36 | double complex R(ldr,*),s(*) 37 | double precision c(*) 38 | external xerbla,zlartg 39 | double complex t 40 | integer info,i,ii,j 41 | c quick return if possible. 42 | if (m == 0 .or. m == 1 .or. n == 0) return 43 | c check arguments. 44 | info = 0 45 | if (m < 0) then 46 | info = 1 47 | else if (n < 0) then 48 | info = 2 49 | else if (ldr < m) then 50 | info = 4 51 | end if 52 | if (info /= 0) then 53 | call xerbla('ZQHQR',info) 54 | return 55 | end if 56 | do i = 1,n 57 | c apply stored rotations, column-wise 58 | t = R(1,i) 59 | ii = min(m,i) 60 | do j = 1,ii-1 61 | R(j,i) = c(j)*t + s(j)*R(j+1,i) 62 | t = c(j)*R(j+1,i) - conjg(s(j))*t 63 | end do 64 | if (ii < m) then 65 | c generate next rotation 66 | call zlartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) 67 | R(ii+1,i) = 0d0 68 | else 69 | R(ii,i) = t 70 | end if 71 | end do 72 | end subroutine 73 | -------------------------------------------------------------------------------- /src/qrupdate/zqrdec.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | 22 | subroutine zqrdec(m,n,k,Q,ldq,R,ldr,j,rw) 23 | c purpose: updates a QR factorization after deleting 24 | c a column. 25 | c i.e., given an m-by-k unitary matrix Q, an k-by-n 26 | c upper trapezoidal matrix R and index j in the range 27 | c 1:n+1, this subroutine updates the matrix Q -> Q1 and 28 | c R -> R1 so that Q1 remains unitary, R1 is upper 29 | c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], 30 | c where A = Q*R. 31 | c (complex version) 32 | c arguments: 33 | c m (in) number of rows of the matrix Q. 34 | c n (in) number of columns of the matrix R. 35 | c k (in) number of columns of Q, and rows of R. Must be 36 | c either k = m (full Q) or k = n < m (economical form, 37 | c basis dimension will decrease). 38 | c Q (io) on entry, the unitary m-by-k matrix Q. 39 | c on exit, the updated matrix Q1. 40 | c ldq (in) leading dimension of Q. ldq >= m. 41 | c R (io) on entry, the original matrix R. 42 | c on exit, the updated matrix R1. 43 | c ldr (in) leading dimension of R. ldr >= k. 44 | c j (in) the position of the deleted column in R. 45 | c 1 <= j <= n. 46 | c rw (o) a real workspace vector of size k-j. 47 | c 48 | integer m,n,k,ldq,ldr,j 49 | double complex Q(ldq,*),R(ldr,*) 50 | double precision rw(*) 51 | external xerbla,zcopy,zqhqr,zqrot 52 | integer info,i 53 | c quick return if possible. 54 | if (m == 0 .or. n == 0 .or. j == n) return 55 | c check arguments. 56 | info = 0 57 | if (m < 0) then 58 | info = 1 59 | else if (n < 0) then 60 | info = 2 61 | else if (k /= m .and. (k /= n .or. n >= m)) then 62 | info = 3 63 | else if (ldq < m) then 64 | info = 5 65 | else if (ldr < k) then 66 | info = 7 67 | else if (j < 1 .or. j > n+1) then 68 | info = 8 69 | end if 70 | if (info /= 0) then 71 | call xerbla('ZQRDEC',info) 72 | return 73 | end if 74 | 75 | c delete the j-th column. 76 | do i = j,n-1 77 | call zcopy(k,R(1,i+1),1,R(1,i),1) 78 | end do 79 | c retriangularize. 80 | if (j < k) then 81 | call zqhqr(k+1-j,n-j,R(j,j),ldr,rw,R(1,n)) 82 | c apply rotations to Q. 83 | call zqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,rw,R(1,n)) 84 | end if 85 | end subroutine 86 | -------------------------------------------------------------------------------- /src/qrupdate/zqrder.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | 22 | subroutine zqrder(m,n,Q,ldq,R,ldr,j,w,rw) 23 | c purpose: updates a QR factorization after deleting a row. 24 | c i.e., given an m-by-m unitary matrix Q, an m-by-n 25 | c upper trapezoidal matrix R and index j in the range 26 | c 1:m, this subroutine updates Q ->Q1 and an R -> R1 27 | c so that Q1 is again unitary, R1 upper trapezoidal, 28 | c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. 29 | c (complex version) 30 | c 31 | c arguments: 32 | c m (in) number of rows of the matrix Q. 33 | c n (in) number of columns of the matrix R. 34 | c Q (io) on entry, the unitary matrix Q. 35 | c on exit, the updated matrix Q1. 36 | c ldq (in) leading dimension of Q. ldq >= m. 37 | c R (io) on entry, the original matrix R. 38 | c on exit, the updated matrix R1. 39 | c ldr (in) leading dimension of R. ldr >= m. 40 | c j (in) the position of the deleted row. 41 | c w (out) a workspace vector of size m. 42 | c rw (out) a real workspace vector of size m. 43 | c 44 | integer m,n,j,ldq,ldr 45 | double complex Q(ldq,*),R(ldr,*),w(*) 46 | double precision rw(*) 47 | external xerbla,zcopy,zqrtv1,zqrot,zqrqh 48 | integer info,i,k 49 | c quick return if possible 50 | if (m == 1) return 51 | c check arguments 52 | info = 0 53 | if (m < 1) then 54 | info = 1 55 | else if (j < 1 .or. j > m) then 56 | info = 7 57 | end if 58 | if (info /= 0) then 59 | call xerbla('ZQRDER',info) 60 | return 61 | end if 62 | c eliminate Q(j,2:m). 63 | do k = 1,m 64 | w(k) = conjg(Q(j,k)) 65 | end do 66 | call zqrtv1(m,w,rw) 67 | c apply rotations to Q. 68 | call zqrot('B',m,m,Q,ldq,rw,w(2)) 69 | c form Q1. 70 | do k = 1,m-1 71 | if (j > 1) call zcopy(j-1,Q(1,k+1),1,Q(1,k),1) 72 | if (j < m) call zcopy(m-j,Q(j+1,k+1),1,Q(j,k),1) 73 | end do 74 | c apply rotations to R. 75 | call zqrqh(m,n,R,ldr,rw,w(2)) 76 | c form R1. 77 | do k = 1,n 78 | do i = 1,m-1 79 | R(i,k) = R(i+1,k) 80 | end do 81 | end do 82 | end subroutine 83 | -------------------------------------------------------------------------------- /src/qrupdate/zqrot.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zqrot(dir,m,n,Q,ldq,c,s) 22 | c purpose: Apply a sequence of inv. rotations from right 23 | c 24 | c arguments: 25 | c dir (in) if 'B' or 'b', rotations are applied from backwards 26 | c if 'F' or 'f', from forwards. 27 | c m (in) number of rows of matrix Q 28 | c n (in) number of columns of the matrix Q 29 | c Q (io) on entry, the matrix Q 30 | c on exit, the updated matrix Q1 31 | c ldq (in) the leading dimension of Q 32 | c c (in) n-1 rotation cosines 33 | c s (in) n-1 rotation sines 34 | c 35 | character dir 36 | integer m,n,ldq 37 | double complex Q(ldq,*),s(*) 38 | double precision c(*) 39 | external zrot,lsame 40 | logical lsame,fwd 41 | integer info,i 42 | c quick return if possible 43 | if (m == 0 .or. n == 0 .or. n == 1) return 44 | c check arguments. 45 | info = 0 46 | fwd = lsame(dir,'F') 47 | if (.not.(fwd .or. lsame(dir,'B'))) then 48 | info = 1 49 | else if (m < 0) then 50 | info = 2 51 | else if (n < 0) then 52 | info = 3 53 | else if (ldq < m) then 54 | info = 5 55 | end if 56 | if (info /= 0) then 57 | call xerbla('ZQROT',info) 58 | return 59 | end if 60 | 61 | if (fwd) then 62 | do i = 1,n-1 63 | call zrot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) 64 | end do 65 | else 66 | do i = n-1,1,-1 67 | call zrot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) 68 | end do 69 | end if 70 | end subroutine 71 | -------------------------------------------------------------------------------- /src/qrupdate/zqrqh.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zqrqh(m,n,R,ldr,c,s) 22 | c purpose: brings an upper trapezoidal matrix R into upper 23 | c Hessenberg form using min(m-1,n) Givens rotations. 24 | c (complex version) 25 | c arguments: 26 | c m (in) number of rows of the matrix R 27 | c n (in) number of columns of the matrix R 28 | c R (io) on entry, the upper Hessenberg matrix R 29 | c on exit, the updated upper trapezoidal matrix 30 | c ldr (in) leading dimension of R, >= m 31 | c c(in) rotation cosines, size at least min(m-1,n) 32 | c s(in) rotation sines, size at least min(m-1,n) 33 | c 34 | integer m,n,ldr 35 | double complex R(ldr,*),s(*) 36 | double precision c(*) 37 | external xerbla 38 | double complex t 39 | integer info,i,ii,j 40 | c quick return if possible. 41 | if (m == 0 .or. m == 1 .or. n == 0) return 42 | c check arguments. 43 | info = 0 44 | if (m < 0) then 45 | info = 1 46 | else if (n < 0) then 47 | info = 2 48 | else if (ldr < m) then 49 | info = 4 50 | end if 51 | if (info /= 0) then 52 | call xerbla('ZQRQH',info) 53 | return 54 | end if 55 | do i = 1,n 56 | c apply stored rotations, column-wise 57 | ii = min(m-1,i) 58 | t = R(ii+1,i) 59 | do j = ii,1,-1 60 | R(j+1,i) = c(j)*t - conjg(s(j))*R(j,i) 61 | t = c(j)*R(j,i) + s(j)*t 62 | end do 63 | R(1,i) = t 64 | end do 65 | end subroutine 66 | -------------------------------------------------------------------------------- /src/qrupdate/zqrtv1.f: -------------------------------------------------------------------------------- 1 | c Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic 2 | c 3 | c Author: Jaroslav Hajek 4 | c 5 | c This file is part of qrupdate. 6 | c 7 | c qrupdate is free software; you can redistribute it and/or modify 8 | c it under the terms of the GNU General Public License as published by 9 | c the Free Software Foundation; either version 3 of the License, or 10 | c (at your option) any later version. 11 | c 12 | c This program is distributed in the hope that it will be useful, 13 | c but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | c GNU General Public License for more details. 16 | c 17 | c You should have received a copy of the GNU General Public License 18 | c along with this software; see the file COPYING. If not, see 19 | c . 20 | c 21 | subroutine zqrtv1(n,u,w) 22 | c purpose: generates a sequence of n-1 Givens rotations that 23 | c eliminate all but the first element of a vector u. 24 | c arguments: 25 | c n (in) the length of the vector u 26 | c u (io) on entry, the vector u. 27 | c on exit, u(2:n) contains the rotation sines, u(1) 28 | c contains the remaining element. 29 | c w (o) on exit, w contains the rotation cosines. 30 | c 31 | integer n 32 | double complex u(*) 33 | double precision w(*) 34 | external zlartg 35 | double complex rr,t 36 | integer i 37 | c quick return if possible. 38 | if (n <= 0) return 39 | rr = u(n) 40 | do i = n-1,1,-1 41 | call zlartg(u(i),rr,w(i),u(i+1),t) 42 | rr = t 43 | end do 44 | u(1) = rr 45 | end subroutine 46 | -------------------------------------------------------------------------------- /src/sparskit2/distdot.f: -------------------------------------------------------------------------------- 1 | C DISDOT - Re-implementation of DDOT required for ITERS.F solvers. 2 | double precision function distdot(n, x, ix, y, iy) 3 | implicit none 4 | integer n, ix, iy 5 | real*8 x(*), y(*) 6 | real*8 ddot 7 | external ddot 8 | distdot = ddot(n, x, ix, y, iy) 9 | end function -------------------------------------------------------------------------------- /tests/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | include("${PROJECT_SOURCE_DIR}/cmake/helper.cmake") 2 | 3 | # Get FORTRAN_TEST_HELPER 4 | add_subdirectory(fortran_test_helper) 5 | 6 | # Fortran API tests source code 7 | set(linalg_test_sources 8 | linalg_test.f90 9 | test_core.f90 10 | test_qr.f90 11 | test_svd.f90 12 | test_cholesky.f90 13 | test_eigen.f90 14 | test_mtx_inverse.f90 15 | test_misc.f90 16 | test_lu.f90 17 | test_sort.f90 18 | test_lq.f90 19 | test_sparse.f90 20 | ) 21 | 22 | # Build the Fortran API tests 23 | add_executable(linalg_test ${linalg_test_sources}) 24 | link_library(linalg_test linalg ${PROJECT_INCLUDE_DIR}) 25 | link_library(linalg_test ${fortran_test_helper_LIBRARY} ${fortran_test_helper_INCLUDE_DIR}) 26 | add_test( 27 | NAME linalg_test 28 | WORKING_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} 29 | COMMAND $ 30 | ) 31 | -------------------------------------------------------------------------------- /tests/fortran_test_helper/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | include(FetchContent) 2 | FetchContent_Declare( 3 | fortran_test_helper 4 | GIT_TAG "origin/main" 5 | GIT_REPOSITORY https://github.com/jchristopherson/fortran_test_helper 6 | OVERRIDE_FIND_PACKAGE 7 | ) 8 | FetchContent_MakeAvailable(fortran_test_helper) 9 | set(fortran_test_helper_INCLUDE_DIR ${fortran_test_helper_BINARY_DIR}/include) 10 | set(fortran_test_helper_LIBRARY fortran_test_helper) 11 | 12 | set(fortran_test_helper_INCLUDE_DIR ${fortran_test_helper_INCLUDE_DIR} PARENT_SCOPE) 13 | set(fortran_test_helper_LIBRARY ${fortran_test_helper_LIBRARY} PARENT_SCOPE) -------------------------------------------------------------------------------- /tests_c/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | include("${PROJECT_SOURCE_DIR}/cmake/helper.cmake") 2 | 3 | # C API tests 4 | if (${BUILD_C_API}) 5 | message(STATUS "Building LINALG C API tests.") 6 | 7 | include_directories( 8 | ${CMAKE_CURRENT_SOURCE_DIR} 9 | ${CMAKE_SOURCE_DIR}/include 10 | ${ferror_INCLUDE_DIR} 11 | ) 12 | 13 | set(linalg_c_test_sources 14 | c_linalg_test.c 15 | c_test_core.c 16 | c_linalg_test_misc.c 17 | c_linalg_test_factor.c 18 | c_linalg_test_eigen.c 19 | ) 20 | 21 | # Build the C API tests 22 | add_executable(linalg_c_test ${linalg_c_test_sources}) 23 | link_library(linalg_c_test linalg ${PROJECT_INCLUDE_DIR}) 24 | add_test( 25 | NAME linalg_c_test 26 | WORKING_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} 27 | COMMAND $ 28 | ) 29 | endif() -------------------------------------------------------------------------------- /tests_c/c_linalg_test.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "c_linalg_test.h" 3 | 4 | int main() 5 | { 6 | // Variables 7 | bool check; 8 | int flag = 0; 9 | 10 | // Tests 11 | check = test_diagonal_mtx_mult(); 12 | if (!check) flag = 1; 13 | check = test_cmplx_diagonal_mtx_mult(); 14 | if (!check) flag = -1; 15 | 16 | check = test_rank1_update(); 17 | if (!check) flag = 2; 18 | check = test_cmplx_rank1_update(); 19 | if (!check) flag = -2; 20 | 21 | check = test_trace(); 22 | if (!check) flag = 3; 23 | check = test_cmplx_trace(); 24 | if (!check) flag = -3; 25 | 26 | check = test_triangular_matrix_multiply(); 27 | if (!check) flag = 4; 28 | check = test_cmplx_triangular_matrix_multiply(); 29 | if (!check) flag = -4; 30 | 31 | check = test_lu(); 32 | if (!check) flag = 5; 33 | check = test_cmplx_lu(); 34 | if (!check) flag = -5; 35 | 36 | check = test_qr(); 37 | if (!check) flag = 6; 38 | check = test_cmplx_qr(); 39 | if (!check) flag = -6; 40 | 41 | check = test_qr_pivot(); 42 | if (!check) flag = 7; 43 | check = test_cmplx_qr_pivot(); 44 | if (!check) flag = -7; 45 | 46 | check = test_qr_rank1_update(); 47 | if (!check) flag = 8; 48 | check = test_cmplx_qr_rank1_update(); 49 | if (!check) flag = -8; 50 | 51 | check = test_cholesky(); 52 | if (!check) flag = 9; 53 | check = test_cmplx_cholesky(); 54 | if (!check) flag = -9; 55 | 56 | check = test_cholesky_rank1_update(); 57 | if (!check) flag = 10; 58 | check = test_cmplx_cholesky_rank1_update(); 59 | if (!check) flag = -10; 60 | 61 | check = test_svd(); 62 | if (!check) flag = 11; 63 | check = test_cmplx_svd(); 64 | if (!check) flag = -11; 65 | 66 | check = test_inverse(); 67 | if (!check) flag = 12; 68 | check = test_cmplx_inverse(); 69 | if (!check) flag = -12; 70 | 71 | check = test_eigen_symm(); 72 | if (!check) flag = 13; 73 | 74 | check = test_eigen_asymm(); 75 | if (!check) flag = 14; 76 | check = test_cmplx_eigen_asymm(); 77 | if (!check) flag = -14; 78 | 79 | check = test_eigen_gen(); 80 | if (!check) flag = 15; 81 | 82 | check = test_lq(); 83 | if (!check) flag = 16; 84 | 85 | check = test_cmplx_lq(); 86 | if (!check) flag = 17; 87 | 88 | // End 89 | return flag; 90 | } 91 | -------------------------------------------------------------------------------- /tests_c/c_linalg_test.h: -------------------------------------------------------------------------------- 1 | #ifndef C_LINALG_TEST_H_DEFINED 2 | #define C_LINALG_TEST_H_DEFINED 3 | 4 | #include 5 | #include 6 | 7 | // c_linalg_test_misc.c 8 | bool test_diagonal_mtx_mult(); 9 | bool test_cmplx_diagonal_mtx_mult(); 10 | bool test_rank1_update(); 11 | bool test_cmplx_rank1_update(); 12 | bool test_trace(); 13 | bool test_cmplx_trace(); 14 | bool test_matrix_mulitply(); 15 | bool test_cmplx_matrix_mulitply(); 16 | bool test_triangular_matrix_multiply(); 17 | bool test_cmplx_triangular_matrix_multiply(); 18 | 19 | // c_linalg_test_factor.c 20 | bool test_lu(); 21 | bool test_cmplx_lu(); 22 | bool test_qr(); 23 | bool test_cmplx_qr(); 24 | bool test_qr_pivot(); 25 | bool test_cmplx_qr_pivot(); 26 | bool test_qr_rank1_update(); 27 | bool test_cmplx_qr_rank1_update(); 28 | bool test_cholesky(); 29 | bool test_cmplx_cholesky(); 30 | bool test_cholesky_rank1_update(); 31 | bool test_cmplx_cholesky_rank1_update(); 32 | bool test_svd(); 33 | bool test_cmplx_svd(); 34 | bool test_inverse(); 35 | bool test_cmplx_inverse(); 36 | bool test_lq(); 37 | bool test_cmplx_lq(); 38 | 39 | // c_linalg_test_eigen.c 40 | bool test_eigen_symm(); 41 | bool test_eigen_asymm(); 42 | bool test_cmplx_eigen_asymm(); 43 | bool test_eigen_gen(); 44 | 45 | #endif 46 | --------------------------------------------------------------------------------