├── .github └── workflows │ └── CI.yml ├── .gitignore ├── .gitmodules ├── CMakeLists.txt ├── LICENSE ├── Makefile ├── README.md ├── build_gfortran.rsp ├── build_ifort.rsp ├── config ├── CMakeLists.txt ├── DefaultFlags.cmake ├── cmake │ └── Findtest-drive.cmake ├── template.cmake └── template.pc ├── doc ├── DoxygenConfigFortran ├── README.md ├── customdoxygen.css ├── documentation.md └── mainpage.md ├── examples ├── Makefile ├── crsinput.ascii ├── matrixija.ascii ├── test1.f90 ├── test10.f90 ├── test1_ll.f90 ├── test2.f90 ├── test3.f90 ├── test4.f90 ├── test5.f90 ├── test6.f90 ├── test7.f90 ├── test8.f90 └── test9.f90 ├── fpm.toml ├── src ├── CMakeLists.txt ├── Makefile ├── dgtrsm.f ├── modcommon.f90 ├── modmetis.f90 ├── modrandom.f90 ├── modspainv.f90 ├── modsparse.f90 ├── modsparse_coo.f90 ├── modsparse_crs.f90 ├── modsparse_crs64.f90 ├── modsparse_gen.f90 ├── modsparse_hash.f90 ├── modsparse_ll.f90 ├── modsparse_metisgraph.f90 ├── modsparse_mkl.f90 ├── modvariablepardiso.f90 ├── sgtrsm.f └── smbfct.f ├── test ├── CMakeLists.txt ├── Makefile ├── modtest_common.f90 ├── modtest_coo.f90 ├── modtest_crs.f90 ├── modtest_crs64.f90 ├── modtest_random.f90 └── test_sparse.f90 ├── test_gfortran.rsp └── test_ifort.rsp /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | env: 6 | CMAKE_BUILD_PARALLEL_LEVEL: "2" # 2 cores on each GHA VM, enable parallel builds 7 | CTEST_OUTPUT_ON_FAILURE: "ON" # This way we don't need a flag to ctest 8 | CTEST_PARALLEL_LEVEL: "2" 9 | CTEST_TIME_TIMEOUT: "5" # some failures hang forever 10 | HOMEBREW_NO_ANALYTICS: "ON" # Make Homebrew installation a little quicker 11 | HOMEBREW_NO_AUTO_UPDATE: "ON" 12 | HOMEBREW_NO_BOTTLE_SOURCE_FALLBACK: "ON" 13 | HOMEBREW_NO_GITHUB_API: "ON" 14 | HOMEBREW_NO_INSTALL_CLEANUP: "ON" 15 | 16 | jobs: 17 | Build: 18 | runs-on: ${{ matrix.os }} 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | # os: [ubuntu-latest, macos-12] 23 | os: [ubuntu-latest] 24 | toolchain: 25 | # - {compiler: gcc, version: 10} 26 | # - {compiler: gcc, version: 11} 27 | # - {compiler: gcc, version: 12} 28 | # - {compiler: gcc, version: 13} 29 | - {compiler: intel, version: '2024.2'} 30 | - {compiler: intel, version: '2024.1'} 31 | - {compiler: intel-classic, version: '2021.9'} 32 | build: [cmake] 33 | env: 34 | BUILD_DIR: ${{ matrix.build == 'cmake' && 'build' || '.' }} 35 | MKL_PACKAGES: >- 36 | intel-oneapi-mkl 37 | intel-oneapi-mkl-devel 38 | 39 | steps: 40 | - name: Checkout code 41 | uses: actions/checkout@v4 42 | 43 | - name: Set up Python 3.x 44 | uses: actions/setup-python@v5 # Use pip to install latest CMake, & FORD/Jin2For, etc. 45 | with: 46 | python-version: 3.x 47 | 48 | - name: Install fypp 49 | run: pip install --upgrade fypp ninja 50 | 51 | - name: Setup Fortran compiler 52 | uses: fortran-lang/setup-fortran@v1.6.1 53 | id: setup-fortran 54 | with: 55 | compiler: ${{ matrix.toolchain.compiler }} 56 | version: ${{ matrix.toolchain.version }} 57 | 58 | - name: Install Intel OneAPI MKL 59 | run: | 60 | sudo apt-get install ${MKL_PACKAGES} 61 | source /opt/intel/oneapi/mkl/latest/env/vars.sh 62 | printenv >> $GITHUB_ENV 63 | 64 | - name: Configure with CMake 65 | if: ${{ contains(matrix.build, 'cmake') }} 66 | run: >- 67 | cmake -Wdev 68 | -DCMAKE_BUILD_TYPE=Debug 69 | -DCMAKE_INSTALL_PREFIX=$PWD/_dist 70 | -S . -B ${{ env.BUILD_DIR }} 71 | 72 | - name: Build and compile 73 | if: ${{ contains(matrix.build, 'cmake') }} 74 | run: cmake --build ${{ env.BUILD_DIR }} --parallel 75 | 76 | - name: catch build fail 77 | run: cmake --build ${{ env.BUILD_DIR }} --verbose --parallel 1 78 | if: ${{ failure() && contains(matrix.build, 'cmake') }} 79 | 80 | - name: test 81 | if: ${{ contains(matrix.build, 'cmake') }} 82 | run: >- 83 | ctest 84 | --test-dir ${{ env.BUILD_DIR }} 85 | --parallel 86 | --output-on-failure 87 | --no-tests=error 88 | 89 | - name: Install project 90 | if: ${{ contains(matrix.build, 'cmake') }} 91 | run: cmake --install ${{ env.BUILD_DIR }} 92 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.mod 2 | *.smod 3 | *.o 4 | *.a 5 | *.optrpt 6 | out.* 7 | tests/testdrive.f90 8 | 9 | build 10 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "test-drive"] 2 | path = test-drive 3 | url = https://github.com/fortran-lang/test-drive.git 4 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Based on test-drive 2 | # License test-drive: 3 | # This file is part of test-drive. 4 | # SPDX-Identifier: Apache-2.0 OR MIT 5 | # 6 | # Licensed under either of Apache License, Version 2.0 or MIT license 7 | # at your option; you may not use this file except in compliance with 8 | # the License. 9 | # 10 | # Unless required by applicable law or agreed to in writing, software 11 | # distributed under the License is distributed on an "AS IS" BASIS, 12 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | # See the License for the specific language governing permissions and 14 | # limitations under the License. 15 | 16 | cmake_minimum_required(VERSION 3.27.0) 17 | 18 | # Include overwrites before setting up the project 19 | set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_CURRENT_SOURCE_DIR}/config/DefaultFlags.cmake) 20 | 21 | get_directory_property(is-subproject PARENT_DIRECTORY) 22 | 23 | project( 24 | "libsparse" 25 | LANGUAGES Fortran C 26 | VERSION "0.1.0" 27 | DESCRIPTION "Sparse matrices" 28 | ) 29 | 30 | # Follow GNU conventions for installing directories 31 | include(GNUInstallDirs) 32 | 33 | # General configuration information 34 | add_subdirectory("config") 35 | 36 | if(NOT TARGET "OpenMP::OpenMP_Fortran") 37 | find_package("OpenMP" REQUIRED) 38 | endif() 39 | 40 | #MKL 41 | message(STATUS "ENV{MKLROOT}: $ENV{MKLROOT}") 42 | 43 | if(NOT TARGET "MKL::MKL") 44 | list(APPEND CMAKE_PREFIX_PATH "$ENV{MKLROOT}/lib/cmake/mkl") 45 | set(MKL_INTERFACE "lp64") 46 | set(MKL_LINK "static") 47 | set(ENABLE_BLAS95 true) 48 | set(ENABLE_LAPACK95 true) 49 | find_package(MKL REQUIRED) 50 | endif() 51 | 52 | message(STATUS "MKL found: ${MKL_IMPORTED_TARGETS}") 53 | 54 | # Find METIS library 55 | if(NOT DEFINED CMAKE_METIS_LIB) 56 | find_library(CMAKE_METIS_LIB metis) 57 | endif() 58 | 59 | if(CMAKE_METIS_LIB) 60 | set(WITH_METIS 1 STRING) 61 | message(STATUS "METIS found: ${CMAKE_METIS_LIB}") 62 | else() 63 | set(WITH_METIS 0 STRING) 64 | message(STATUS "METIS not found") 65 | endif() 66 | 67 | set( 68 | lib-deps 69 | "OpenMP::OpenMP_Fortran" 70 | "MKL::MKL" 71 | ) 72 | 73 | if(CMAKE_METIS_LIB) 74 | list( 75 | APPEND lib-deps 76 | "${CMAKE_METIS_LIB}" 77 | ) 78 | endif() 79 | 80 | #MKL PARDISO 81 | #if(NOT CMAKE_MKLPARDISO AND NOT CMAKE_Fortran_COMPILER_ID MATCHES "^Intel") 82 | # find_file(CMAKE_MKLPARDISO "mkl_pardiso.f90" HINTS $ENV{MKLROOT} PATH_SUFFIXES "include") 83 | #endif() 84 | 85 | #if(CMAKE_MKLPARDISO OR CMAKE_Fortran_COMPILER_ID MATCHES "^Intel" ) 86 | set(WITH_MKLPARDISO 1 STRING) 87 | #else() 88 | # set(WITH_MKLPARDISO 0 STRING) 89 | #endif() 90 | message(STATUS "Support of MKL PARDISO: ${WITH_MKLPARDISO}") 91 | 92 | #SPAINV 93 | if(NOT DEFINED CMAKE_SPAINV) 94 | set(WITH_SPAINV 1 CACHE STRING "Support of SPAINV") 95 | else() 96 | set(WITH_SPAINV ${CMAKE_SPAINV} CACHE STRING "Support of SPAINV") 97 | endif() 98 | 99 | #SPAINV 100 | if(NOT DEFINED CMAKE_VERBOSE) 101 | set(WITH_VERBOSE 0 CACHE STRING "Support of verbosity") 102 | else() 103 | set(WITH_VERBOSE ${CMAKE_VERBOSE} CACHE STRING "Support of verbosity") 104 | endif() 105 | 106 | 107 | 108 | # Collect source of the project 109 | set(srcs) 110 | add_subdirectory("src") 111 | 112 | # We need the module directory before we finish the configure stage 113 | if(NOT EXISTS "${PROJECT_BINARY_DIR}/include") 114 | make_directory("${PROJECT_BINARY_DIR}/include") 115 | endif() 116 | 117 | # Testing library target 118 | add_library( 119 | "${PROJECT_NAME}-lib" 120 | "${srcs}" 121 | ) 122 | set_target_properties( 123 | "${PROJECT_NAME}-lib" 124 | PROPERTIES 125 | POSITION_INDEPENDENT_CODE TRUE 126 | OUTPUT_NAME "${PROJECT_NAME}" 127 | VERSION "${PROJECT_VERSION}" 128 | SOVERSION "${PROJECT_VERSION_MAJOR}" 129 | Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include" 130 | ) 131 | target_link_libraries( 132 | "${PROJECT_NAME}-lib" 133 | PUBLIC 134 | "${lib-deps}" 135 | ) 136 | target_include_directories( 137 | "${PROJECT_NAME}-lib" 138 | PUBLIC 139 | $ 140 | $ 141 | "$ENV{MKLROOT}/include" #SHOULD BE OPTIONAL 142 | ) 143 | target_compile_definitions( 144 | "${PROJECT_NAME}-lib" 145 | PRIVATE 146 | "-D_DP=1" 147 | "-D_METIS=${WITH_METIS}" 148 | "-D_PARDISO=${WITH_MKLPARDISO}" 149 | "-D_SPAINV=${WITH_SPAINV}" 150 | "-D_VERBOSE=${WITH_VERBOSE}" 151 | ) 152 | 153 | # Export targets for other projects 154 | add_library("${PROJECT_NAME}" INTERFACE) 155 | target_link_libraries("${PROJECT_NAME}" INTERFACE "${PROJECT_NAME}-lib") 156 | install( 157 | TARGETS 158 | "${PROJECT_NAME}" 159 | "${PROJECT_NAME}-lib" 160 | EXPORT 161 | "${PROJECT_NAME}-targets" 162 | LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" 163 | ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" 164 | ) 165 | install( 166 | EXPORT 167 | "${PROJECT_NAME}-targets" 168 | NAMESPACE 169 | "${PROJECT_NAME}::" 170 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 171 | ) 172 | install( 173 | DIRECTORY 174 | "${PROJECT_BINARY_DIR}/include/" 175 | DESTINATION "${CMAKE_INSTALL_INCLUDEDIR}/${module-dir}" 176 | ) 177 | # Package license files 178 | install( 179 | FILES 180 | "LICENSE" 181 | DESTINATION "${CMAKE_INSTALL_DATADIR}/licenses/${PROJECT_NAME}" 182 | ) 183 | 184 | 185 | # add the testsuite 186 | include(CTest) 187 | if(BUILD_TESTING AND LIBSPARSE_BUILD_TESTING) 188 | add_subdirectory("test") 189 | endif() 190 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Jeremie Vandenplas 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #Makefile 2 | 3 | DEBUGENABLE=0 4 | DPENABLE=1 5 | METISENABLE=0 6 | PARDISOENABLE=1 7 | SPAINVENABLE=1 8 | VERBOSE=0 9 | 10 | FC = gfortran 11 | #FC = ifort 12 | 13 | #ifort 14 | ifeq ($(FC), ifort) 15 | FFLAGS=-O3 -fpp -heap-arrays -qopenmp -parallel -qopt-matmul -qopt-report=5 16 | FFLAGS+=-I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 17 | 18 | FLIBS += -liomp5 -lmkl_blas95_lp64 -lmkl_lapack95_lp64 -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core 19 | FLIBS += -lpthread -lm -ldl 20 | 21 | ifeq ($(DEBUGENABLE), 1) 22 | FFLAGS += -g -check all -traceback -debug extended -debug inline-debug-info -check noarg_temp_created -warn all 23 | endif 24 | 25 | endif 26 | 27 | 28 | #gfortan 29 | ifeq ($(FC), gfortran) 30 | FFLAGS=-O3 -cpp -fopenmp -fall-intrinsics 31 | FFLAGS+=-I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 32 | 33 | FLIBS += -Wl,--start-group ${MKLROOT}/lib/intel64/libmkl_gf_lp64.a ${MKLROOT}/lib/intel64/libmkl_gnu_thread.a ${MKLROOT}/lib/intel64/libmkl_core.a -Wl,--end-group -lgomp 34 | FLIBS += -lpthread -lm -ldl 35 | 36 | ifeq ($(DEBUGENABLE), 1) 37 | FFLAGS += -g -Wall -fcheck=all -fbacktrace -std=f2008 38 | endif 39 | 40 | endif 41 | 42 | #ifx 43 | ifeq ($(FC), ifx) 44 | FFLAGS=-O3 -fpp -heap-arrays -qopenmp -parallel -qopt-matmul -qopt-report=5 45 | FFLAGS+=-I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 46 | 47 | FLIBS += -liomp5 -lmkl_blas95_lp64 -lmkl_lapack95_lp64 -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core 48 | FLIBS += -lpthread -lm -ldl 49 | 50 | ifeq ($(DEBUGENABLE), 1) 51 | FFLAGS += -g -check all -traceback -debug extended -debug inline-debug-info -check noarg_temp_created -warn all 52 | endif 53 | 54 | endif 55 | 56 | 57 | ifeq ($(METISENABLE), 1) 58 | LIBMETISROOT=~/metis-5.1.0 59 | LIBMETIS=$(LIBMETISROOT)/build/Linux-x86_64/libmetis 60 | FLIBS += $(LIBMETIS)/libmetis.a 61 | METIS = 1 62 | else 63 | METIS = 0 64 | endif 65 | 66 | 67 | ifeq ($(DPENABLE),0) 68 | DP=0 69 | else 70 | DP=1 71 | endif 72 | 73 | ifeq ($(PARDISOENABLE),1) 74 | PARDISO=1 75 | else 76 | PARDISO=0 77 | endif 78 | 79 | 80 | ifeq ($(SPAINVENABLE),1) 81 | SPAINV=1 82 | else 83 | SPAINV=0 84 | endif 85 | 86 | FFLAGS += -D_DP=$(DP) -D_METIS=$(METIS) -D_PARDISO=$(PARDISO) -D_SPAINV=$(SPAINV) -D_VERBOSE=$(VERBOSE) 87 | 88 | FYPPFLAGS = 89 | 90 | export FC 91 | export FFLAGS 92 | export FLIBS 93 | export FYPPFLAGS 94 | 95 | export METISENABLE 96 | export PARDISOENABLE 97 | export SPAINVENABLE 98 | 99 | .PHONY: all clean examples lib test 100 | 101 | all: lib 102 | $(MAKE) --directory=test 103 | 104 | examples: 105 | $(MAKE) --directory=examples 106 | 107 | lib: 108 | $(MAKE) --directory=src -j 109 | 110 | test: all 111 | $(MAKE) --directory=test test 112 | @echo 113 | @echo "All tests passed." 114 | 115 | clean: 116 | $(MAKE) clean --directory=src 117 | $(MAKE) clean --directory=examples 118 | $(MAKE) clean --directory=test 119 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Fortran library to handle sparse matrices 2 | 3 | 4 | ## Overview 5 | The Fortran 2003 library __libsparse__ is a library that provides objects to create and handle rectangular and square sparse matrices using different formats: 6 | 7 | * Linked List (LL); 8 | 9 | 10 | * COOrdinate storage (COO) (with elements stored using a hashing function); 11 | 12 | 13 | * Compressed Row Storage (CRS). 14 | 15 | 16 | The library is written following an object-oriented approach. It has been tested mainly on small datasets. 17 | 18 | 19 | 20 | ## Compilation 21 | To build the `libsparse` you need (at least): 22 | 23 | * at least a Fortran 2008 compliant compiler (GCC Fortran 11 and Intel Fortran 24 | classic compilers have been tested successfully); 25 | * Intel MKL library; 26 | * Make or CMake or fpm. 27 | 28 | The library relies on different libraries, such as BLAS/LAPACK libraries (currently on Intel MKL library), and optionally on PARDISO (at this stage, Intel MKL PARDISO), and on [METIS 5](http://glaros.dtc.umn.edu/gkhome/metis/metis/overview). 29 | The library can be built with the compilers `gfortran` and `ifort`. 30 | 31 | 32 | See the brief [documentation](doc/documentation.md) for more details regarding the compilation. 33 | 34 | 35 | ## Documentation 36 | The brief documentation is available in the directory *doc* (see *mainpage.md*). An extended documentation can be generated with *Doxygen*. 37 | 38 | 39 | ## Acknowledgements 40 | This library was inspired by several sources: 41 | 42 | 43 | * http://burtleburtle.net/bob/hash/index.html#lookup 44 | 45 | 46 | * https://didgeridoo.une.edu.au/km/homepage.php 47 | 48 | 49 | * https://genomeek.wordpress.com/ 50 | 51 | 52 | * https://gist.github.com/n-s-k/522f2669979ed6d0582b8e80cf6c95fd 53 | 54 | 55 | * https://nce.ads.uga.edu/wiki/lib/exe/fetch.php?media=sparse90.pdf 56 | 57 | 58 | * https://www.netlib.org/lapack/explore-html/index.html 59 | 60 | 61 | * https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/755612 62 | 63 | 64 | * and by many courses related to object-oriented programming and Fortran 2003/2008. 65 | 66 | ## To be implemented 67 | 68 | * Check for symmetric matrix 69 | 70 | * Allow the option spainv + single precision 71 | 72 | * Full support of 8-byte integers 73 | -------------------------------------------------------------------------------- /build_gfortran.rsp: -------------------------------------------------------------------------------- 1 | #defaults for compiling with gfortran 2 | options build 3 | options --flag "-O3 -fall-intrinsics -I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 -L${LMETIS}" 4 | -------------------------------------------------------------------------------- /build_ifort.rsp: -------------------------------------------------------------------------------- 1 | #defaults for compiling with ifort 2 | options build 3 | options --flag "-O3 -heap-arrays -parallel -qopt-matmul -qopt-report=5 -I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 -L${LMETIS}" 4 | options --compiler ifort 5 | -------------------------------------------------------------------------------- /config/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Based on test-drive. 2 | # 3 | # License test-drive: 4 | # SPDX-Identifier: MIT 5 | # 6 | # Licensed under either of Apache License, Version 2.0 or MIT license 7 | # at your option; you may not use this file except in compliance with 8 | # the License. 9 | # 10 | # Unless required by applicable law or agreed to in writing, software 11 | # distributed under the License is distributed on an "AS IS" BASIS, 12 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | # See the License for the specific language governing permissions and 14 | # limitations under the License. 15 | 16 | option(BUILD_SHARED_LIBS "Whether the libraries built should be shared" FALSE) 17 | option(LIBSPARSE_BUILD_TESTING "Enable testing for this project" ON) 18 | 19 | set( 20 | module-dir 21 | "${PROJECT_NAME}" 22 | # "${PROJECT_NAME}/${CMAKE_Fortran_COMPILER_ID}-${CMAKE_Fortran_COMPILER_VERSION}" 23 | ) 24 | set(module-dir "${module-dir}" PARENT_SCOPE) 25 | 26 | # Set build type as CMake does not provide defaults 27 | if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) 28 | set( 29 | CMAKE_BUILD_TYPE "Release" 30 | CACHE STRING "Build type to be used." 31 | FORCE 32 | ) 33 | message( 34 | STATUS 35 | "Setting build type to '${CMAKE_BUILD_TYPE}' as none was specified." 36 | ) 37 | endif() 38 | 39 | include(CheckFortranSourceRuns) 40 | check_fortran_source_runs( 41 | "if (selected_real_kind(33) == -1) stop 1; end" 42 | WITH_QP 43 | ) 44 | set(WITH_QP ${WITH_QP} PARENT_SCOPE) 45 | 46 | 47 | list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") 48 | set(CMAKE_MODULE_PATH "${CMAKE_MODULE_PATH}" PARENT_SCOPE) 49 | install( 50 | DIRECTORY 51 | "${CMAKE_CURRENT_SOURCE_DIR}/cmake/" 52 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 53 | ) 54 | 55 | include(CMakePackageConfigHelpers) 56 | configure_package_config_file( 57 | "${CMAKE_CURRENT_SOURCE_DIR}/template.cmake" 58 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config.cmake" 59 | INSTALL_DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 60 | ) 61 | write_basic_package_version_file( 62 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" 63 | VERSION "${PROJECT_VERSION}" 64 | COMPATIBILITY SameMinorVersion 65 | ) 66 | install( 67 | FILES 68 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config.cmake" 69 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" 70 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 71 | ) 72 | 73 | configure_file( 74 | "${CMAKE_CURRENT_SOURCE_DIR}/template.pc" 75 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc" 76 | @ONLY 77 | ) 78 | install( 79 | FILES 80 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc" 81 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig" 82 | ) 83 | -------------------------------------------------------------------------------- /config/DefaultFlags.cmake: -------------------------------------------------------------------------------- 1 | #Based on Fortran stdlib (License: MIT) 2 | 3 | if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") 4 | set( 5 | CMAKE_Fortran_FLAGS_INIT 6 | "-cpp" 7 | "-fall-intrinsics" 8 | ) 9 | set( 10 | CMAKE_Fortran_FLAGS_RELEASE_INIT 11 | "-O3" 12 | ) 13 | set( 14 | CMAKE_Fortran_FLAGS_DEBUG_INIT 15 | "-g" 16 | "-fcheck=all" 17 | "-fbacktrace" 18 | "-Wall" 19 | "-Wextra" 20 | "-Wimplicit-procedure" 21 | # "-std=f2018" 22 | ) 23 | elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^IntelLLVM") 24 | set( 25 | CMAKE_Fortran_FLAGS_INIT 26 | "-fpp" 27 | "-qopt-report=3" 28 | "-traceback" 29 | ) 30 | set( 31 | CMAKE_Fortran_FLAGS_RELEASE_INIT 32 | "-O3" 33 | ) 34 | if(WIN32) 35 | set( 36 | CMAKE_Fortran_FLAGS_DEBUG_INIT 37 | "/stand:f18" 38 | "/warn:declarations,general,usage,interfaces,unused" 39 | ) 40 | else() 41 | set( 42 | CMAKE_Fortran_FLAGS_DEBUG_INIT 43 | "-g" 44 | "-stand f18" 45 | "-check all,nouninit -traceback -debug extended -debug inline-debug-info -check noarg_temp_created" 46 | "-warn all" 47 | ) 48 | endif() 49 | elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^Intel") 50 | set( 51 | CMAKE_Fortran_FLAGS_INIT 52 | "-fpp" 53 | "-heap-arrays" 54 | "-qopt-report=5" 55 | "-qopt-matmul" 56 | ) 57 | set( 58 | CMAKE_Fortran_FLAGS_RELEASE_INIT 59 | "-O3" 60 | "-parallel" 61 | "-qopt-matmul" 62 | ) 63 | if(WIN32) 64 | set( 65 | CMAKE_Fortran_FLAGS_DEBUG_INIT 66 | "/stand:f18" 67 | "/warn:declarations,general,usage,interfaces,unused" 68 | ) 69 | else() 70 | set( 71 | CMAKE_Fortran_FLAGS_DEBUG_INIT 72 | "-stand f18" 73 | "-g" 74 | "-check all -traceback -debug extended -debug inline-debug-info" 75 | "-check noarg_temp_created" 76 | "-warn all" 77 | ) 78 | endif() 79 | else() 80 | set( 81 | CMAKE_Fortran_FLAGS_INIT 82 | ) 83 | set( 84 | CMAKE_Fortran_FLAGS_RELEASE_INIT 85 | ) 86 | set( 87 | CMAKE_Fortran_FLAGS_DEBUG_INIT 88 | ) 89 | endif() 90 | string(REPLACE ";" " " CMAKE_Fortran_FLAGS_INIT "${CMAKE_Fortran_FLAGS_INIT}") 91 | string(REPLACE ";" " " CMAKE_Fortran_FLAGS_RELEASE_INIT "${CMAKE_Fortran_FLAGS_RELEASE_INIT}") 92 | string(REPLACE ";" " " CMAKE_Fortran_FLAGS_DEBUG_INIT "${CMAKE_Fortran_FLAGS_DEBUG_INIT}") 93 | -------------------------------------------------------------------------------- /config/cmake/Findtest-drive.cmake: -------------------------------------------------------------------------------- 1 | # SPDX-Identifier: MIT 2 | 3 | #[[.rst: 4 | Find test-drive 5 | --------------- 6 | 7 | Makes the test-drive project available. 8 | 9 | Imported Targets 10 | ^^^^^^^^^^^^^^^^ 11 | 12 | This module provides the following imported target, if found: 13 | 14 | ``test-drive::test-drive`` 15 | The test-drive library 16 | 17 | 18 | Result Variables 19 | ^^^^^^^^^^^^^^^^ 20 | 21 | This module will define the following variables: 22 | 23 | ``TEST_DRIVE_FOUND`` 24 | True if the test-drive library is available 25 | 26 | ``TEST_DRIVE_SOURCE_DIR`` 27 | Path to the source directory of the test-drive project, 28 | only set if the project is included as source. 29 | 30 | ``TEST_DRIVE_BINARY_DIR`` 31 | Path to the binary directory of the test-drive project, 32 | only set if the project is included as source. 33 | 34 | Cache variables 35 | ^^^^^^^^^^^^^^^ 36 | 37 | The following cache variables may be set to influence the library detection: 38 | 39 | ``TEST_DRIVE_FIND_METHOD`` 40 | Methods to find or make the project available. Available methods are 41 | - ``cmake``: Try to find via CMake config file 42 | - ``pkgconf``: Try to find via pkg-config file 43 | - ``subproject``: Use source in subprojects directory 44 | - ``fetch``: Fetch the source from upstream 45 | 46 | ``TEST_DRIVE_DIR`` 47 | Used for searching the CMake config file 48 | 49 | ``TEST_DRIVE_SUBPROJECT`` 50 | Directory to find the test-drive subproject, relative to the project root 51 | 52 | #]] 53 | 54 | set(_lib "test-drive") 55 | set(_pkg "TEST_DRIVE") 56 | set(_url "https://github.com/fortran-lang/test-drive") 57 | 58 | if(NOT DEFINED "${_pkg}_FIND_METHOD") 59 | if(DEFINED "${PROJECT_NAME}-dependency-method") 60 | set("${_pkg}_FIND_METHOD" "${${PROJECT_NAME}-dependency-method}") 61 | else() 62 | set("${_pkg}_FIND_METHOD" "cmake" "pkgconf" "subproject" "fetch") 63 | endif() 64 | set("_${_pkg}_FIND_METHOD") 65 | endif() 66 | 67 | foreach(method ${${_pkg}_FIND_METHOD}) 68 | if(TARGET "${_lib}::${_lib}") 69 | break() 70 | endif() 71 | 72 | if("${method}" STREQUAL "cmake") 73 | message(STATUS "${_lib}: Find installed package") 74 | if(DEFINED "${_pkg}_DIR") 75 | set("_${_pkg}_DIR") 76 | set("${_lib}_DIR" "${_pkg}_DIR") 77 | endif() 78 | find_package("${_lib}" CONFIG QUIET) 79 | if("${_lib}_FOUND") 80 | message(STATUS "${_lib}: Found installed package") 81 | break() 82 | endif() 83 | endif() 84 | 85 | if("${method}" STREQUAL "pkgconf") 86 | find_package(PkgConfig QUIET) 87 | pkg_check_modules("${_pkg}" QUIET "${_lib}") 88 | if("${_pkg}_FOUND") 89 | message(STATUS "Found ${_lib} via pkg-config") 90 | 91 | add_library("${_lib}::${_lib}" INTERFACE IMPORTED) 92 | target_link_libraries( 93 | "${_lib}::${_lib}" 94 | INTERFACE 95 | "${${_pkg}_LINK_LIBRARIES}" 96 | ) 97 | target_include_directories( 98 | "${_lib}::${_lib}" 99 | INTERFACE 100 | "${${_pkg}_INCLUDE_DIRS}" 101 | ) 102 | 103 | break() 104 | endif() 105 | endif() 106 | 107 | if("${method}" STREQUAL "subproject") 108 | if(NOT DEFINED "${_pkg}_SUBPROJECT") 109 | set("_${_pkg}_SUBPROJECT") 110 | set("${_pkg}_SUBPROJECT" "subprojects/${_lib}") 111 | endif() 112 | set("${_pkg}_SOURCE_DIR" "${PROJECT_SOURCE_DIR}/${${_pkg}_SUBPROJECT}") 113 | set("${_pkg}_BINARY_DIR" "${PROJECT_BINARY_DIR}/${${_pkg}_SUBPROJECT}") 114 | if(EXISTS "${${_pkg}_SOURCE_DIR}/CMakeLists.txt") 115 | message(STATUS "Include ${_lib} from ${${_pkg}_SUBPROJECT}") 116 | add_subdirectory( 117 | "${${_pkg}_SOURCE_DIR}" 118 | "${${_pkg}_BINARY_DIR}" 119 | ) 120 | 121 | add_library("${_lib}::${_lib}" INTERFACE IMPORTED) 122 | target_link_libraries("${_lib}::${_lib}" INTERFACE "${_lib}") 123 | 124 | # We need the module directory in the subproject before we finish the configure stage 125 | if(NOT EXISTS "${${_pkg}_BINARY_DIR}/include") 126 | make_directory("${${_pkg}_BINARY_DIR}/include") 127 | endif() 128 | 129 | break() 130 | endif() 131 | endif() 132 | 133 | if("${method}" STREQUAL "fetch") 134 | message(STATUS "Retrieving ${_lib} from ${_url}") 135 | include(FetchContent) 136 | FetchContent_Declare( 137 | "${_lib}" 138 | GIT_REPOSITORY "${_url}" 139 | GIT_TAG "HEAD" 140 | ) 141 | FetchContent_MakeAvailable("${_lib}") 142 | 143 | add_library("${_lib}::${_lib}" INTERFACE IMPORTED) 144 | target_link_libraries("${_lib}::${_lib}" INTERFACE "${_lib}") 145 | 146 | # We need the module directory in the subproject before we finish the configure stage 147 | FetchContent_GetProperties("${_lib}" SOURCE_DIR "${_pkg}_SOURCE_DIR") 148 | FetchContent_GetProperties("${_lib}" BINARY_DIR "${_pkg}_BINARY_DIR") 149 | if(NOT EXISTS "${${_pkg}_BINARY_DIR}/include") 150 | make_directory("${${_pkg}_BINARY_DIR}/include") 151 | endif() 152 | 153 | break() 154 | endif() 155 | 156 | endforeach() 157 | 158 | if(TARGET "${_lib}::${_lib}") 159 | set("${_pkg}_FOUND" TRUE) 160 | else() 161 | set("${_pkg}_FOUND" FALSE) 162 | endif() 163 | 164 | if(DEFINED "_${_pkg}_SUBPROJECT") 165 | unset("${_pkg}_SUBPROJECT") 166 | unset("_${_pkg}_SUBPROJECT") 167 | endif() 168 | if(DEFINED "_${_pkg}_DIR") 169 | unset("${_lib}_DIR") 170 | unset("_${_pkg}_DIR") 171 | endif() 172 | if(DEFINED "_${_pkg}_FIND_METHOD") 173 | unset("${_pkg}_FIND_METHOD") 174 | unset("_${_pkg}_FIND_METHOD") 175 | endif() 176 | unset(_lib) 177 | unset(_pkg) 178 | unset(_url) 179 | -------------------------------------------------------------------------------- /config/template.cmake: -------------------------------------------------------------------------------- 1 | @PACKAGE_INIT@ 2 | 3 | set("@PROJECT_NAME@_WITH_QP" @WITH_QP@) 4 | 5 | if(NOT TARGET "@PROJECT_NAME@::@PROJECT_NAME@") 6 | include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") 7 | endif() 8 | -------------------------------------------------------------------------------- /config/template.pc: -------------------------------------------------------------------------------- 1 | prefix=@CMAKE_INSTALL_PREFIX@ 2 | libdir=${prefix}/@CMAKE_INSTALL_LIBDIR@ 3 | includedir=${prefix}/@CMAKE_INSTALL_INCLUDEDIR@ 4 | 5 | Name: @PROJECT_NAME@ 6 | Description: @PROJECT_DESCRIPTION@ 7 | Version: @PROJECT_VERSION@ 8 | Libs: -L${libdir} -l@PROJECT_NAME@ 9 | Cflags: -I${includedir} -I${includedir}/@module-dir@ 10 | -------------------------------------------------------------------------------- /doc/README.md: -------------------------------------------------------------------------------- 1 | The creation of the manaul with Doxygen can be done as follows: 2 | 3 | doxygen DoxygenConfigFortran 4 | 5 | 6 | -------------------------------------------------------------------------------- /doc/customdoxygen.css: -------------------------------------------------------------------------------- 1 | /* 2 | div.contents { 3 | width of 80 characters monospace plus line numbers 4 | width: 51em; 5 | margin: 0px auto; 6 | text-align: justify; 7 | } 8 | */ 9 | 10 | .title { 11 | text-align: center; 12 | } 13 | 14 | div.fragment { 15 | overflow: auto; 16 | } 17 | 18 | div.fragment div.line { 19 | white-space: pre; 20 | } 21 | -------------------------------------------------------------------------------- /doc/documentation.md: -------------------------------------------------------------------------------- 1 | ## Brief documentation 2 | 3 | 4 | ## Overview 5 | The Modern Fortran library __libsparse__ is a library that provides objects to create and handle rectangular and square sparse matrices using different formats: 6 | 7 | * Linked List (LL); 8 | 9 | 10 | * COOrdinate storage (COO) (with elements stored using a hashing function); 11 | 12 | 13 | * Compressed Row Storage (CRS). 14 | 15 | 16 | The library is written following an object-oriented approach. 17 | 18 | 19 | ## Compilation 20 | 21 | To build the `libsparse` you need (at least): 22 | 23 | * at least a Fortran 2008 compliant compiler (GCC Fortran 11 and Intel Fortran 24 | classic compilers have been tested successfully); 25 | * Intel MKL library; 26 | * Make or fpm. 27 | 28 | The library relies on different libraries, such as BLAS/LAPACK libraries (currently Intel MKL library), and optionally on PARDISO (at this stage, Intel MKL PARDISO), and [METIS 5](http://glaros.dtc.umn.edu/gkhome/metis/metis/overview). 29 | 30 | ### Building with Make 31 | 32 | To compile with GCC Fortran compiler `gfortran`: 33 | 34 | ```shell 35 | make FC=gfortran 36 | ``` 37 | 38 | or to compile with Intel Fortran classic compiler `ifort` 39 | ```shell 40 | make FC=ifort 41 | ``` 42 | 43 | By default, it will not be compiled against METIS 5. To compile against METIS 5: 44 | 45 | ```shel 46 | make FC=ifort METISENABLE=1 47 | ``` 48 | 49 | Compilation with debug options is possible by adding the argument `DEBUGENABLE=1`. 50 | 51 | Compilation for single precision is possible by adding the argument `DPENABLE=0`. 52 | 53 | 54 | ### Build with CMake 55 | 56 | Configure the build with, e.g., 57 | 58 | ```sh 59 | export FFLAGS="-O3" 60 | cmake -B build -DCMAKE_VERBOSE_MAKEFILE=On -DCMAKE_BUILD_TYPE=Debug -DCMAKE_METIS_LIB=$(pwd)/../metis-5.1.0/build/Linux-x86_64/libmetis/libmetis.a 61 | ``` 62 | 63 | To build the project, run 64 | 65 | ```sh 66 | cmake --build build 67 | ``` 68 | 69 | To test your build, run the test suite after the build has finished with 70 | 71 | ```sh 72 | cmake --build build --target test 73 | ``` 74 | 75 | ### Building with fpm 76 | 77 | To compile with GCC Fortran compiler `gfortran`: 78 | 79 | ```shell 80 | fpm @build_gfortran 81 | fpm @test_gfortran 82 | ``` 83 | 84 | or to compile with Intel Fortran classic compiler `ifort` 85 | ```shell 86 | fpm @build_ifort 87 | fpm @test_ifort 88 | ``` 89 | Note that the file `fpm.toml` must be modified for supporting the compilation with 90 | `ifort`. 91 | 92 | ## Methods 93 | 94 | Below the term *mat* refers to one of the three available sparse objects (i.e., llsparse, coosparse, or crssparse), except if it is mentioned otherwise. For more details, please refer to the documentation generated by Doxygen. 95 | 96 | To __construct__ (__initiate__) a sparse matrix, the constructor of the same name as the object, must be used, e.g.: 97 | 98 | ```` 99 | integer :: dim1 !number of rows 100 | type(coosparse) :: mat 101 | 102 | dim1 = 100 103 | mat = coosparse(dim1) 104 | ```` 105 | 106 | Other options are possible for the constructor (see details in the module pages). For sparse matrices with upper storage (default: fulled storage), it must be mentioned as: 107 | 108 | ```` 109 | mat = coosparse(dim1,lupper=.true.) 110 | ```` 111 | 112 | This option can also be used to __load__ a matrix from a binary stream file. 113 | 114 | 115 | To __add__ a value *val* at the position (*row*,*col*) of a sparse matrix, the method *add* must be used, e.g.: 116 | 117 | ```` 118 | call mat%add(row, col, val) 119 | ```` 120 | 121 | To __convert__ a sparse matrix from a format to another format, the assignment = can be used. E.g., to convert from COO to CSR: 122 | 123 | ```` 124 | type(coosparse) :: coomat 125 | type(crssparse) :: crsmat 126 | 127 | csrmat = coomat 128 | ```` 129 | 130 | To __copy__ a sparse matrix, the assignment = can be used. E.g.,: 131 | 132 | ```` 133 | type(crssparse) :: crsmat 134 | type(crssparse) :: crsmatcopy 135 | 136 | csrmatcopy = crsmat 137 | ```` 138 | 139 | To __deallocate__ a sparse matrix, the method *destroy* can be used, e.g.: 140 | 141 | ```` 142 | call mat%destroy() 143 | ```` 144 | 145 | To extract the __diagonal elements__ of a sparse matrix into a array, the method *diag* must be used: 146 | 147 | ```` 148 | array = mat%diag() 149 | ```` 150 | 151 | To extract the __diagonal elements__ and __off-diagonals__ of a sparse matrix into a array, the method *diag* must be used: 152 | 153 | ```` 154 | extractedmat = mat%diag(x) 155 | ```` 156 | 157 | 158 | where *x* is the number of off-diagonals (next to the diagonal) that must be extraced. If *x* is equal to 0, only the diagonal will be extracted and stored into a sparse matrix. 159 | 160 | To __get a value *val*__ at the position (*row*,*col*) of a sparse matrix, the method *get* must be used, e.g.: 161 | 162 | ```` 163 | val = mat%get(row, col) 164 | ```` 165 | 166 | To __get one of the dimensions__ of a sparse matrix, the method *getdim* must be used: 167 | 168 | ```` 169 | val = mat%getdim(x) 170 | ```` 171 | where *x* is 1 (=*number of rows*) or 2 (=*number of columns*). 172 | 173 | To __get a permutation vector__ from the METIS 5 fill-reducing ordering approach, the method *getordering* can be used: 174 | 175 | ```` 176 | permarray = mat%getordering() 177 | ```` 178 | 179 | Options for METIS 5 can be changed through optional arguments of this method. 180 | 181 | 182 | To __approximate the diagonal elements of the inverse__ of a sparse matrix using 183 | Harville (1999): 184 | 185 | ```` 186 | call crsmat%harville(ngibbs, nburn, diaginv) 187 | ```` 188 | 189 | To __create__ a CRS matrix from __existing arrays__, the method *external* must be used: 190 | 191 | ```` 192 | call crsmat%external(ia, ja, a) 193 | ```` 194 | 195 | where the arrays *ia*, *ja*, and *a* must have the same size as the ones of the sparse matrix *crsmat*. 196 | 197 | To __multiply__ a sparse matrix by a vector as, *y = alpha \* mat(trans) \* v + val \* y* , the method *multbyv* must be used: 198 | 199 | ```` 200 | call mat%multbyv(alpha, trans, v, val, y) 201 | ```` 202 | where *alpha* and *val* are double-precision real values, *v* and *y* are vectors, and *trans* (= 'n' or 't') relates to the transposition of the matrix. 203 | The method *multbyv* is based on the MKL Sparse BLAS library. 204 | 205 | To get the number of __non-zero elements__ of a sparse matrix, the method *nonzero* must be used, e.g.: 206 | 207 | ```` 208 | nonzeros = mat%nonzero() 209 | ```` 210 | 211 | 212 | To __print__ a sparse matrix as stored __to default output__ (screen), the method *print* must be used, e.g.: 213 | 214 | 215 | ```` 216 | call mat%print() 217 | ```` 218 | 219 | To __print__ a sparse matrix as stored __to a file__ called *file.dat*, the method *printtofile* must be used, e.g.: 220 | 221 | 222 | ```` 223 | call mat%printtofile('file.dat') 224 | ```` 225 | 226 | 227 | To __save__ a matrix in the internal format, the method *save* can be used: 228 | 229 | ```` 230 | call mat%save('file.stream') 231 | ```` 232 | 233 | To __set an entry__ to a specified value (even __0__), the method *set* can be used: 234 | 235 | ```` 236 | call mat%set(row, col, val) 237 | ```` 238 | 239 | To __set a permutation vector__,the method *setpermutation* can be used: 240 | 241 | ```` 242 | call mat%setpermutation(array) 243 | ```` 244 | 245 | It is possible to get and set a permutation vector in one call as follows: 246 | 247 | ```` 248 | call mat%setpermutation(mat%getordering()) 249 | ```` 250 | 251 | 252 | To __solve__ a linear system of equations of the form *mat \* x = y*, the method *solve* must be used: 253 | 254 | ```` 255 | call mat%solve(x,y) 256 | ```` 257 | The method *solve* is based on Intel MKL Pardiso. If a permutation vector was provided with the method `setpermutation`, this permutation vector will be used by Intel MKL Pardiso (instead of determining it internally). 258 | 259 | 260 | To __sort__ a column (in an ascending order) within a row of a CRS sparse matrix, the method *sort* must be used: 261 | 262 | ```` 263 | call crsmat%sort() 264 | ```` 265 | 266 | To check if the sparse matrix is sorted (columns within rows), the method __issorted__ must be used: 267 | 268 | ```` 269 | sorted = mat%issorted() 270 | ```` 271 | 272 | where the variable __sorted__ is a logical. 273 | 274 | 275 | To check if the sparse matrix is a *square* matrix, the method __issquare__ must be used: 276 | 277 | ```` 278 | square = mat%issquare() 279 | ```` 280 | 281 | where the variable __square__ is a logical. 282 | 283 | 284 | To extract a __submatrix__ from a sparse matrix, the method *submatrix* must be used, e.g.: 285 | 286 | ```` 287 | submatrix = mat%submatrix(startrow, endrow, startrow, endrow, lupper = log) 288 | ```` 289 | 290 | where *log* is a logical to extract the full matrix (`lupper = .false.`) or the upper triangular matrix (`lupper = .true.`). 291 | 292 | -------------------------------------------------------------------------------- /doc/mainpage.md: -------------------------------------------------------------------------------- 1 | ## Libsparse Documentation 2 | 3 | 4 | ## Overview 5 | The Fortran 2003 library __libsparse__ is a library that provides objects to create and handle rectangular and square sparse matrices using different formats: 6 | 7 | * Linked List (LL); 8 | 9 | 10 | * COOrdinate storage (COO) (with elements stored using a hashing function); 11 | 12 | 13 | * Compressed Row Storage (CRS). 14 | 15 | 16 | The library is written following an object-oriented approach. It has been tested mainly on small datasets. 17 | 18 | 19 | 20 | ## Compilation 21 | The library relies on different libraries, such as BLAS/LAPACK libraries, PARDISO (at this stage, Intel MKL PARDISO), and [METIS 5] (http://glaros.dtc.umn.edu/gkhome/metis/metis/overview). 22 | 23 | 24 | See the brief [documentation] (documentation.md) for more details regarding the compilation. 25 | 26 | 27 | ## Documentation 28 | The brief [documentation] (documentation.md) is available in the directory *doc*. An extended documentation can be generated with *Doxygen*. 29 | 30 | 31 | ## Acknowledgements 32 | This library was inspired by several sources: 33 | 34 | 35 | * http://burtleburtle.net/bob/hash/index.html#lookup 36 | 37 | 38 | * https://didgeridoo.une.edu.au/km/homepage.php 39 | 40 | 41 | * https://genomeek.wordpress.com/ 42 | 43 | 44 | * https://gist.github.com/n-s-k/522f2669979ed6d0582b8e80cf6c95fd 45 | 46 | 47 | * https://nce.ads.uga.edu/wiki/lib/exe/fetch.php?media=sparse90.pdf 48 | 49 | 50 | * https://www.netlib.org/lapack/explore-html/index.html 51 | 52 | 53 | * https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/755612 54 | 55 | 56 | * https://stackoverflow.com/questions/466204/rounding-up-to-next-power-of-2 57 | 58 | 59 | * and by many courses related to object-oriented programming and Fortran 2003/2008. 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | FFLAGS+=-I../src 2 | 3 | LIB = ../src/libsparse.a 4 | 5 | EXEC= 6 | 7 | ifeq ($(METISENABLE),0) 8 | else 9 | EXEC+=test5 10 | endif 11 | 12 | ifeq ($(SPAINVENABLE),0) 13 | else 14 | EXEC+=test6 15 | endif 16 | 17 | EXEC+=test1 test2 test3 test4 test1_ll test7 test8 test9 test10 18 | 19 | all: $(EXEC) 20 | 21 | %: %.f90 22 | $(FC) $(FFLAGS) $(DEBUG) $^ $(LIB) $(FLIBS) -o $@ 23 | 24 | clean: 25 | rm -fv *.dat *.o *.optrpt $(EXEC) 26 | -------------------------------------------------------------------------------- /examples/crsinput.ascii: -------------------------------------------------------------------------------- 1 | 4 2 | 1 3 1.2 3 | 1 2 1. 4 | 3 3 3.4 5 | 3 1 2.3 6 | 3 2 5.0 7 | 3 1 10.3 8 | 2 1 0.1 9 | 2 2 0.0 10 | 2 3 0.3 11 | 4 3 0.5 12 | -------------------------------------------------------------------------------- /examples/matrixija.ascii: -------------------------------------------------------------------------------- 1 | 23 2 | 1 1 14.285 3 | 1 13 1.428 4 | 1 9 1.428 5 | 1 21 1.428 6 | 1 18 1.428 7 | 1 10 1.428 8 | 1 14 1.428 9 | 1 11 1.428 10 | 1 15 1.428 11 | 1 3 .814 12 | 1 7 1.428 13 | 1 2 7.142 14 | 1 4 1.428 15 | 2 2 4.257 16 | 2 18 .285 17 | 2 14 .714 18 | 2 21 .428 19 | 2 15 1.142 20 | 2 11 .714 21 | 2 13 .428 22 | 2 7 1.142 23 | 2 9 1.142 24 | 2 3 .351 25 | 2 10 .428 26 | 2 4 .714 27 | 3 3 .058 28 | 3 14 .128 29 | 3 10 .071 30 | 3 18 .128 31 | 3 21 .071 32 | 3 11 .128 33 | 3 13 .071 34 | 3 15 .028 35 | 3 9 .028 36 | 3 7 .028 37 | 3 4 .128 38 | 4 4 9.761 39 | 4 14 -3.333 40 | 4 7 1.666 41 | 4 9 -3.333 42 | 4 6 1.666 43 | 4 8 1.666 44 | 4 10 -3.333 45 | 5 5 5.000 46 | 5 7 1.666 47 | 5 11 -3.333 48 | 6 6 5.000 49 | 6 10 -3.333 50 | 7 7 9.761 51 | 7 17 -3.333 52 | 7 14 -3.333 53 | 7 13 1.666 54 | 7 11 -3.333 55 | 8 8 5.000 56 | 8 9 -3.333 57 | 9 9 14.206 58 | 9 16 -3.333 59 | 9 15 -3.333 60 | 9 13 -3.333 61 | 9 11 3.333 62 | 9 12 -.555 63 | 10 10 8.095 64 | 11 11 13.095 65 | 11 20 -3.333 66 | 11 13 -1.666 67 | 11 15 -3.333 68 | 12 12 9.444 69 | 12 23 -3.333 70 | 12 19 -3.333 71 | 12 15 1.666 72 | 12 20 1.666 73 | 12 16 -3.333 74 | 13 13 11.428 75 | 13 20 -3.333 76 | 13 17 -3.333 77 | 14 14 8.095 78 | 15 15 14.761 79 | 15 22 -3.333 80 | 15 21 -3.333 81 | 15 19 -1.666 82 | 15 16 3.333 83 | 15 18 -3.333 84 | 16 16 10.000 85 | 16 22 -3.333 86 | 16 18 -3.333 87 | 17 17 6.666 88 | 18 18 8.095 89 | 19 19 8.333 90 | 19 21 -3.333 91 | 20 20 8.333 92 | 20 23 -3.333 93 | 21 21 8.095 94 | 22 22 6.666 95 | 23 23 6.666 96 | -------------------------------------------------------------------------------- /examples/test1.f90: -------------------------------------------------------------------------------- 1 | program test1 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::nrow 10 | integer(kind=int32)::row 11 | integer(kind=int32)::col 12 | integer(kind=int32)::iunit, istat 13 | real(kind=wp)::val 14 | logical::lup=.false. 15 | type(llsparse)::ll 16 | type(coosparse)::coo 17 | type(crssparse)::crs,crs1 18 | 19 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 20 | !LINKED LINK 21 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 22 | read(iunit,*) nrow 23 | 24 | ll=llsparse(nrow,lupper=lup) 25 | 26 | do 27 | read(iunit,*,iostat=istat) row,col,val 28 | if(istat.ne.0)exit 29 | call ll%add(row,col,val) 30 | end do 31 | close(iunit) 32 | 33 | call ll%printstats() 34 | 35 | call ll%print() 36 | !call coo%print(lint=.false.) 37 | call ll%printtofile('ll.dat') 38 | 39 | print*,'size ll: ',ll%nonzero() 40 | 41 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 42 | !CSR FROM LL 43 | crs=ll 44 | call crs%printstats 45 | call crs%print() 46 | 47 | call crs%sort() 48 | call crs%printtofile('crsll.dat') 49 | 50 | call ll%destroy() 51 | 52 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 53 | !COO 54 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 55 | read(iunit,*) nrow 56 | 57 | coo=coosparse(nrow,nel=4_int64,lupper=lup) 58 | 59 | do 60 | read(iunit,*,iostat=istat) row,col,val 61 | if(istat.ne.0)exit 62 | call coo%add(row,col,val) 63 | end do 64 | close(iunit) 65 | 66 | call coo%printstats() 67 | !call coo%print(lint=.false.) 68 | call coo%print() 69 | call coo%printtofile('coo.dat') 70 | 71 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 72 | !CSR 73 | crs=coo 74 | call crs%printstats 75 | call crs%print() 76 | 77 | call crs%sort() 78 | call crs%printtofile('crscoo.dat') 79 | 80 | 81 | call coo%add(1,1,150._wp) 82 | 83 | ! crs=coo 84 | ! call crs%printstats 85 | ! !call crs%print(lint=.false.) 86 | ! print*,'*****************not sorted' 87 | ! call crs%print() 88 | ! print*,'*****************sorted' 89 | ! call crs%sort() 90 | ! call crs%print() 91 | ! call crs%printtofile('crs.dat') 92 | ! call crs%printtofile('crs_int.dat',lint=.false.) 93 | ! 94 | ! 95 | print*,'aaaaaaaaaaaaaaCOOaaaaaaaaaaaaaaaa' 96 | print*,'4 3',coo%get(4,3) 97 | print*,'3 4',coo%get(3,4) 98 | print*,'3 3',coo%get(3,3) 99 | print*,'1 4',coo%get(1,4) 100 | print*,'1 1',coo%get(1,1) 101 | 102 | !print*,'aaaaaaaaaaaaaaCSRaaaaaaaaaaaaaaaa' 103 | ! print*,'4 3',crs%get(4,3) 104 | ! print*,'3 4',crs%get(3,4) 105 | ! print*,'3 3',crs%get(3,3) 106 | ! print*,'1 4',crs%get(1,4) 107 | ! print*,'1 1',crs%get(1,1) 108 | ! 109 | print*,'aaaaaaaaaaaaaaCOOaaaaaaaaaaaaaaaa' 110 | call coo%printsquare() 111 | !print*,'aaaaaaaaaaaaaaCOOaaaaaaaaaaaaaaaa' 112 | ! call crs%printsquare() 113 | ! call crs%printsquaretofile('crsquarse.dat') 114 | 115 | 116 | print*,'aaaaaaaaaaaaaaCOO modifaaaaaaaaaaaaaaaa' 117 | 118 | call coo%set(4,4,-1._wp) 119 | call coo%set(3,4,-1._wp) 120 | call coo%set(4,3,0._wp) 121 | 122 | 123 | call coo%print() 124 | 125 | call coo%printsquare() 126 | 127 | print*,'aaaaaaaaaaaaaaCRS modifaaaaaaaaaaaaaaaa' 128 | crs=coo 129 | call crs%sort() 130 | call crs%print() 131 | 132 | 133 | print*,'aaaaaaaaaaaaa print COO to stream aaaaaaaaaa' 134 | call coo%save('coostream.dat') 135 | call coo%printstats() 136 | 137 | call coo%destroy() 138 | 139 | print*,'aaaaaaaaaaaaa read COO to stream aaaaaaaaaa' 140 | coo=coosparse('coostream.dat')!,444) 141 | call coo%printstats() 142 | 143 | call coo%destroy() 144 | 145 | print*,'aaaaaaaaaaaaa add to CRS aaaaaaaaaa' 146 | call crs%set(4,4,100._wp,row) 147 | print*,'error: ',row 148 | 149 | call crs%set(1,4,100._wp,row) 150 | print*,'error: ',row 151 | call crs%print() 152 | 153 | print*,'dim1',crs%getdim(1) 154 | print*,'dim2',crs%getdim(2) 155 | 156 | print*,'aaaaaaaaaaaaaaa test load/save aaaaaaaaaaaaaaa' 157 | call crs%save('crsstream.dat') 158 | 159 | crs1=crssparse('crsstream.dat') 160 | call crs1%print() 161 | 162 | print*,'aaaaaaaaaaaaaaa test copy aaaaaaaaaaaaaaa' 163 | call crs%destroy() 164 | 165 | crs=crs1 166 | 167 | print*,'aaaaaaaaaaaaaaaCRSaaaaaaaaaaaaaaa' 168 | call crs%add(1,1,130._wp) 169 | call crs%printstats() 170 | call crs%print() 171 | 172 | print*,'aaaaaaaaaaaaaaaCRS1aaaaaaaaaaaaaaa' 173 | call crs1%printstats() 174 | call crs1%print() 175 | 176 | 177 | print*,'aaaaaaaaaaaaaaa DIAGONAL COO aaaaaaaaaaaaaaaa' 178 | coo=crs1 179 | 180 | call coo%printsquare() 181 | 182 | print*,'aaaa',coo%diag() 183 | 184 | crs=coo%diag(-1) 185 | 186 | call crs%printsquare() 187 | 188 | call coo%destroy() 189 | 190 | print*,'aaaaaaaaaaaaaaa DIAGONAL CRS aaaaaaaaaaaaaaaa' 191 | coo=crs1 192 | crs=coo 193 | call crs%printsquare() 194 | 195 | print*,'aaaa',crs%diag() 196 | crs1=crs%diag(10) 197 | call crs1%printsquare() 198 | 199 | end program 200 | -------------------------------------------------------------------------------- /examples/test10.f90: -------------------------------------------------------------------------------- 1 | program test10 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | #if (_METIS==1) 8 | use modmetis,only:METIS_CTYPE_SHEM 9 | #endif 10 | use modsparse 11 | implicit none 12 | integer(kind=int32)::nrow 13 | integer(kind=int32)::row 14 | integer(kind=int32)::col 15 | integer(kind=int32)::iunit, istat 16 | integer(kind=int32)::i,j 17 | integer(kind=int32),allocatable::iarray(:,:) 18 | integer(kind=int32),allocatable::perm(:) 19 | real(kind=wp)::val 20 | real(kind=wp),allocatable::x(:),y(:) 21 | real(kind=wp),allocatable::xx(:) 22 | logical::lup=.false. 23 | type(coosparse)::coo 24 | type(crssparse)::crs 25 | type(crssparse)::crs1 26 | 27 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 28 | !COO UPPER 29 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 30 | read(iunit,*) nrow 31 | 32 | coo=coosparse(5,lupper=.true.) 33 | 34 | call coo%setsymmetric() 35 | 36 | do 37 | read(iunit,*,iostat=istat) row,col,val 38 | if(istat.ne.0)exit 39 | call coo%add(row,col,val) 40 | end do 41 | close(iunit) 42 | 43 | call coo%add(1,1,10._wp) 44 | call coo%add(2,2,10._wp) 45 | call coo%add(3,3,10._wp) 46 | ! call coo%add(4,4,1._wp) 47 | call coo%add(5,5,1._wp) 48 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 49 | !CSR UPPER 50 | crs=coo 51 | 52 | call crs%printsquare() 53 | 54 | !perm=crs%getordering() 55 | #if (_METIS==1) 56 | perm=crs%getordering(compress=1,ctype=METIS_CTYPE_SHEM) 57 | #else 58 | perm=(/(i,i=1,crs%getdim(1))/) 59 | #endif 60 | 61 | call crs%printstats() 62 | 63 | call crs%setpermutation(perm) 64 | call crs%printstats() 65 | 66 | allocate(x(crs%getdim(1)),y(crs%getdim(1))) 67 | do i=1,crs%getdim(1) 68 | y(i)=i 69 | enddo 70 | y(4)=0 71 | print*,'y=[',y,' ]' 72 | 73 | 74 | x=0._wp 75 | xx=x 76 | call coo%cg(xx,y) 77 | 78 | call crs%solve(x,y) 79 | print*,'xx ',xx 80 | print*,' x ',x 81 | 82 | 83 | end program 84 | -------------------------------------------------------------------------------- /examples/test1_ll.f90: -------------------------------------------------------------------------------- 1 | program test1_ll 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::nrow,i,j 10 | integer(kind=int32)::row 11 | integer(kind=int32)::col 12 | integer(kind=int32)::iunit, istat 13 | real(kind=wp)::val 14 | logical::lup=.false. 15 | type(llsparse)::ll 16 | type(coosparse)::coo 17 | type(crssparse)::crs 18 | 19 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 20 | !LINKED LINK 21 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 22 | read(iunit,*) nrow 23 | 24 | ll=llsparse(nrow,lupper=lup) 25 | 26 | do 27 | read(iunit,*,iostat=istat) row,col,val 28 | if(istat.ne.0)exit 29 | call ll%add(row,col,val) 30 | end do 31 | close(iunit) 32 | 33 | call ll%printstats() 34 | 35 | call ll%print() 36 | !call coo%print(lint=.false.) 37 | call ll%printtofile('ll.dat') 38 | 39 | print*,'size ll: ',ll%nonzero() 40 | 41 | do i=1,ll%getdim(1) 42 | do j=1,ll%getdim(2) 43 | print*,i,j,ll%get(i,j) 44 | enddo 45 | enddo 46 | 47 | end program 48 | -------------------------------------------------------------------------------- /examples/test2.f90: -------------------------------------------------------------------------------- 1 | program test2 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,real64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,real64,wp=>real64 6 | #endif 7 | !$ use omp_lib 8 | use modsparse 9 | implicit none 10 | integer(kind=int32)::nrow 11 | integer(kind=int32)::row,col 12 | integer(kind=int32)::i,j 13 | integer(kind=int64)::nel 14 | real(kind=wp)::val 15 | !$ real(kind=real64)::t1 16 | !$ real(kind=real64)::t2 17 | type(llsparse)::sparse 18 | type(coosparse)::coo 19 | type(crssparse)::crs 20 | 21 | nrow=10000 22 | val=1._wp 23 | nel=1000000_int64 24 | ! nel=67108865_int64 25 | 26 | sparse=llsparse(nrow,lupper=.true.) 27 | !$ t2=0.d0 28 | do i=1,nrow!,2 29 | do j=1,nrow!,3 30 | val=real(i+j,wp) 31 | !$ t1=omp_get_wtime() 32 | call sparse%addtohead(i,j,val) 33 | !$ t2=t2+omp_get_wtime()-t1 34 | enddo 35 | enddo 36 | !!$ write(*,'(/a,f0.3)')' Elapsed time ll: ',omp_get_wtime()-t1 37 | !$ write(*,'(/a,f0.3)')' Elapsed time coo: ',t2 38 | call sparse%printstats() 39 | 40 | !$ t1=omp_get_wtime() 41 | crs=sparse 42 | !$ write(*,'(/a,f0.3)')' Elapsed time crsll: ',omp_get_wtime()-t1 43 | call crs%sort() 44 | call crs%printtofile('crsll.dat') 45 | call sparse%destroy() 46 | 47 | coo=coosparse(nrow,nel=nel,lupper=.true.) 48 | !$ t2=0.d0 49 | !$ t1=omp_get_wtime() 50 | do i=1,nrow!,2 51 | do j=1,nrow!,3 52 | val=real(i+j,wp) 53 | !$ t1=omp_get_wtime() 54 | call coo%add(i,j,val) 55 | !$ t2=t2+omp_get_wtime()-t1 56 | enddo 57 | enddo 58 | !!$ write(*,'(/a,f0.3)')' Elapsed time coo: ',omp_get_wtime()-t1 59 | !$ write(*,'(/a,f0.3)')' Elapsed time coo: ',t2 60 | call coo%printstats() 61 | 62 | !$ t1=omp_get_wtime() 63 | crs=coo 64 | !$ write(*,'(/a,f0.3)')' Elapsed time crs: ',omp_get_wtime()-t1 65 | call crs%printstats() 66 | 67 | call crs%sort() 68 | 69 | call crs%printtofile('crs.dat') 70 | 71 | ! call crs%print() 72 | ! 73 | ! call crs%add(1,2,5._wp,i) 74 | ! print*,'aaaaaa',i 75 | ! call crs%add(2,2,5._wp,i) 76 | ! print*,'aaaaaa',i 77 | ! call crs%print() 78 | end program 79 | 80 | -------------------------------------------------------------------------------- /examples/test3.f90: -------------------------------------------------------------------------------- 1 | program test3 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::nrow 10 | integer(kind=int32)::row 11 | integer(kind=int32)::col 12 | integer(kind=int32)::iunit, istat 13 | real(kind=wp)::val 14 | logical::lup=.false. 15 | type(coosparse)::coo 16 | type(crssparse)::crs,subcrs 17 | 18 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 19 | !COO FULL 20 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 21 | read(iunit,*) nrow 22 | 23 | coo=coosparse(nrow,nel=4_int64,lupper=.false.) 24 | 25 | do 26 | read(iunit,*,iostat=istat) row,col,val 27 | if(istat.ne.0)exit 28 | call coo%add(row,col,val) 29 | end do 30 | close(iunit) 31 | 32 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 33 | !CSR FULL 34 | crs=coo 35 | call crs%printstats 36 | call crs%print(lint=.true.) 37 | 38 | print*,'FULL => FULL xxxxxxxxxxxxxxxxxxxxxxxxxx' 39 | call crs%printsquare() 40 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 41 | print*,'aaaa 1 2 3 4' 42 | subcrs=crs%submatrix(1,2,3,4) 43 | call subcrs%printstats() 44 | call subcrs%printsquare() 45 | 46 | print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 47 | print*,'aaaa 3 4 1 2' 48 | subcrs=crs%submatrix(3,4,1,2) 49 | call subcrs%printstats() 50 | call subcrs%printsquare() 51 | 52 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 53 | print*,'aaaa 1 2 1 3' 54 | subcrs=crs%submatrix(1,2,1,3) 55 | call subcrs%printstats() 56 | call subcrs%printsquare() 57 | 58 | print*,'' 59 | print*,'FULL => UPPER xxxxxxxxxxxxxxxxxxxxxxxxxx' 60 | call crs%printsquare() 61 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 62 | print*,'aaaa 1 2 3 4' 63 | subcrs=crs%submatrix(1,2,3,4,.true.) 64 | call subcrs%printstats() 65 | call subcrs%printsquare() 66 | 67 | print*,'SELECT LOWER BLOCK a xxxxxxxxxxxxxxxxxxxxxxxxxx' 68 | print*,'aaaa 3 4 1 2' 69 | subcrs=crs%submatrix(3,4,1,2,.true.) 70 | call subcrs%printstats() 71 | call subcrs%printsquare() 72 | 73 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 74 | print*,'aaaa 1 2 1 3' 75 | subcrs=crs%submatrix(1,2,1,3,.true.) 76 | call subcrs%printstats() 77 | call subcrs%printsquare() 78 | 79 | 80 | 81 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 82 | !COO UPPER 83 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 84 | read(iunit,*) nrow 85 | 86 | coo=coosparse(nrow,nel=4_int64,lupper=.true.) 87 | 88 | do 89 | read(iunit,*,iostat=istat) row,col,val 90 | if(istat.ne.0)exit 91 | call coo%add(row,col,val) 92 | end do 93 | close(iunit) 94 | 95 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 96 | !CSR UPPER 97 | crs=coo 98 | call crs%printstats() 99 | call crs%print(lint=.true.) 100 | 101 | print*,'UPPER => FULL xxxxxxxxxxxxxxxxxxxxxxxxxx' 102 | call crs%printsquare() 103 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 104 | print*,'aaaa 1 2 3 4' 105 | subcrs=crs%submatrix(1,2,3,4) 106 | call subcrs%printstats() 107 | call subcrs%printsquare() 108 | 109 | print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 110 | print*,'aaaa 3 4 1 2' 111 | subcrs=crs%submatrix(3,4,1,2) 112 | call subcrs%printstats() 113 | call subcrs%printsquare() 114 | 115 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 116 | print*,'aaaa 1 2 1 3' 117 | subcrs=crs%submatrix(1,2,1,3) 118 | call subcrs%printstats() 119 | call subcrs%printsquare() 120 | 121 | print*,'' 122 | print*,'UPPER => UPPER xxxxxxxxxxxxxxxxxxxxxxxxxx' 123 | call crs%printsquare() 124 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 125 | print*,'aaaa 1 2 3 4' 126 | subcrs=crs%submatrix(1,2,3,4,.true.) 127 | call subcrs%printstats() 128 | call subcrs%printsquare() 129 | 130 | print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 131 | print*,'aaaa 3 4 1 2' 132 | subcrs=crs%submatrix(3,4,1,2,.true.) 133 | call subcrs%printstats() 134 | call subcrs%printsquare() 135 | 136 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 137 | print*,'aaaa 1 2 1 3' 138 | subcrs=crs%submatrix(1,2,1,3,.true.) 139 | call subcrs%printstats() 140 | call subcrs%printsquare() 141 | 142 | 143 | 144 | 145 | 146 | 147 | end program 148 | -------------------------------------------------------------------------------- /examples/test4.f90: -------------------------------------------------------------------------------- 1 | program test4 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::nrow 10 | integer(kind=int32)::row 11 | integer(kind=int32)::col 12 | integer(kind=int32)::iunit, istat 13 | real(kind=wp)::val 14 | logical::lup=.false. 15 | type(coosparse)::coo,subcoo 16 | 17 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 18 | !COO FULL 19 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 20 | read(iunit,*) nrow 21 | 22 | coo=coosparse(nrow,nel=4_int64,lupper=.false.) 23 | 24 | do 25 | read(iunit,*,iostat=istat) row,col,val 26 | if(istat.ne.0)exit 27 | call coo%add(row,col,val) 28 | end do 29 | close(iunit) 30 | 31 | 32 | print*,'FULL => FULL xxxxxxxxxxxxxxxxxxxxxxxxxx' 33 | call coo%printsquare() 34 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 35 | print*,'aaaa 1 2 3 4' 36 | subcoo=coo%submatrix(1,2,3,4) 37 | call subcoo%printstats() 38 | call subcoo%printsquare() 39 | 40 | print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 41 | print*,'aaaa 3 4 1 2' 42 | subcoo=coo%submatrix(3,4,1,2) 43 | call subcoo%printstats() 44 | call subcoo%printsquare() 45 | 46 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 47 | print*,'aaaa 1 2 1 3' 48 | subcoo=coo%submatrix(1,2,1,3) 49 | call subcoo%printstats() 50 | call subcoo%printsquare() 51 | 52 | print*,'' 53 | print*,'FULL => UPPER xxxxxxxxxxxxxxxxxxxxxxxxxx' 54 | call coo%printsquare() 55 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 56 | print*,'aaaa 1 2 3 4' 57 | subcoo=coo%submatrix(1,2,3,4,.true.) 58 | call subcoo%printstats() 59 | call subcoo%printsquare() 60 | 61 | print*,'SELECT LOWER BLOCK a xxxxxxxxxxxxxxxxxxxxxxxxxx' 62 | print*,'aaaa 3 4 1 2' 63 | subcoo=coo%submatrix(3,4,1,2,.true.) 64 | call subcoo%printstats() 65 | call subcoo%printsquare() 66 | 67 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 68 | print*,'aaaa 1 2 1 3' 69 | subcoo=coo%submatrix(1,2,1,3,.true.) 70 | call subcoo%printstats() 71 | call subcoo%printsquare() 72 | 73 | 74 | 75 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 76 | !COO UPPER 77 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 78 | read(iunit,*) nrow 79 | 80 | coo=coosparse(nrow,nel=4_int64,lupper=.true.) 81 | 82 | do 83 | read(iunit,*,iostat=istat) row,col,val 84 | if(istat.ne.0)exit 85 | call coo%add(row,col,val) 86 | end do 87 | close(iunit) 88 | 89 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 90 | !COO UPPER 91 | print*,'***COO UPPER' 92 | call coo%printstats() 93 | call coo%print(lint=.true.) 94 | 95 | print*,'UPPER => FULL xxxxxxxxxxxxxxxxxxxxxxxxxx' 96 | call coo%printsquare() 97 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 98 | print*,'aaaa 1 2 3 4' 99 | subcoo=coo%submatrix(1,2,3,4) 100 | call subcoo%printstats() 101 | call subcoo%printsquare() 102 | 103 | print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 104 | print*,'aaaa 3 4 1 2' 105 | subcoo=coo%submatrix(3,4,1,2) 106 | call subcoo%printstats() 107 | call subcoo%printsquare() 108 | 109 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 110 | print*,'aaaa 1 2 1 3' 111 | subcoo=coo%submatrix(1,2,1,3) 112 | call subcoo%printstats() 113 | call subcoo%printsquare() 114 | 115 | print*,'' 116 | print*,'UPPER => UPPER xxxxxxxxxxxxxxxxxxxxxxxxxx' 117 | call coo%printsquare() 118 | print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 119 | print*,'aaaa 1 2 3 4' 120 | subcoo=coo%submatrix(1,2,3,4,.true.) 121 | call subcoo%printstats() 122 | call subcoo%printsquare() 123 | 124 | print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx' 125 | print*,'aaaa 3 4 1 2' 126 | subcoo=coo%submatrix(3,4,1,2,.true.) 127 | call subcoo%printstats() 128 | call subcoo%printsquare() 129 | 130 | print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx' 131 | print*,'aaaa 1 2 1 3' 132 | subcoo=coo%submatrix(1,2,1,3,.true.) 133 | call subcoo%printstats() 134 | call subcoo%printsquare() 135 | 136 | 137 | 138 | end program 139 | -------------------------------------------------------------------------------- /examples/test5.f90: -------------------------------------------------------------------------------- 1 | program test5 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modmetis,only:METIS_CTYPE_SHEM 8 | use modsparse 9 | implicit none 10 | integer(kind=int32)::nrow 11 | integer(kind=int32)::row 12 | integer(kind=int32)::col 13 | integer(kind=int32)::iunit, istat 14 | integer(kind=int32)::i,j 15 | integer(kind=int32),allocatable::iarray(:,:) 16 | integer(kind=int32),allocatable::perm(:) 17 | real(kind=wp)::val 18 | real(kind=wp),allocatable::x(:),y(:) 19 | logical::lup=.false. 20 | type(coosparse)::coo 21 | type(crssparse)::crs 22 | 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | !COO UPPER 25 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 26 | read(iunit,*) nrow 27 | 28 | coo=coosparse(5,nel=4_int64,lupper=.true.) 29 | 30 | do 31 | read(iunit,*,iostat=istat) row,col,val 32 | if(istat.ne.0)exit 33 | call coo%add(row,col,val) 34 | end do 35 | close(iunit) 36 | 37 | call coo%add(5,5,10._wp) 38 | call coo%add(2,5,11._wp) 39 | call coo%add(5,2,11._wp) 40 | 41 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 42 | !CSR UPPER 43 | crs=coo 44 | call crs%print(lint=.true.) 45 | 46 | !perm=crs%getordering() 47 | perm=crs%getordering(compress=1,ctype=METIS_CTYPE_SHEM) 48 | print*,'perm',perm 49 | 50 | call crs%printstats() 51 | 52 | 53 | write(*,*)'aaaaaaaaaaaa' 54 | 55 | call crs%setpermutation(crs%getordering()) 56 | call crs%printstats() 57 | 58 | allocate(x(crs%getdim(1)),y(crs%getdim(1))) 59 | x=1.;y=1. 60 | 61 | call crs%solve(x,y) 62 | 63 | 64 | write(*,*)'aaaaaaaaaaaa' 65 | allocate(iarray(crs%getdim(1),crs%getdim(2))) 66 | iarray=0 67 | do i=1,crs%getdim(1) 68 | do j=1,crs%getdim(2) 69 | val=crs%get(perm(i),perm(j)) 70 | if(val.ne.0.)iarray(i,j)=1 71 | enddo 72 | enddo 73 | 74 | do i=1,crs%getdim(1) 75 | write(*,'(10000(i2))')iarray(i,:) 76 | enddo 77 | 78 | end program 79 | -------------------------------------------------------------------------------- /examples/test6.f90: -------------------------------------------------------------------------------- 1 | program test6 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::nrow 10 | integer(kind=int32)::row 11 | integer(kind=int32)::col 12 | integer(kind=int32)::iunit, istat 13 | integer(kind=int32)::i,j 14 | integer(kind=int32),allocatable::iarray(:,:) 15 | integer(kind=int32),allocatable::perm(:) 16 | real(kind=wp)::val 17 | real(kind=wp),allocatable::x(:),y(:) 18 | logical::lup=.false. 19 | type(coosparse)::coo 20 | type(crssparse)::crs 21 | 22 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 23 | !COO UPPER 24 | open(newunit=iunit,file='matrixija.ascii',status='old',action='read') 25 | !open(newunit=iunit,file='matkm.dat',status='old',action='read') 26 | read(iunit,*) nrow 27 | 28 | coo=coosparse(nrow,lupper=.true.) 29 | 30 | do 31 | read(iunit,*,iostat=istat) row,col,val 32 | if(istat.ne.0)exit 33 | call coo%add(row,col,val) 34 | ! if(row.ne.col)call coo%add(col,row,val) 35 | end do 36 | close(iunit) 37 | 38 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 39 | !CSR UPPER 40 | crs=coo 41 | 42 | call crs%printstats() 43 | 44 | call crs%printsquare() 45 | 46 | #if (_METIS==1) 47 | call crs%setpermutation(crs%getordering(bglvl=0)) 48 | #else 49 | call crs%setpermutation((/(i,i=1,crs%getdim(1))/)) 50 | #endif 51 | call crs%printstats() 52 | 53 | !!!!!!!!!!!!!!!! 54 | write(*,*)'Matrix' 55 | allocate(iarray(crs%getdim(1),crs%getdim(2))) 56 | iarray=0 57 | do i=1,crs%getdim(1) 58 | do j=1,crs%getdim(2) 59 | val=crs%get(i,j) 60 | if(val.ne.0.)iarray(i,j)=1 61 | enddo 62 | enddo 63 | 64 | do i=1,crs%getdim(1) 65 | write(*,'(10000(i2))')iarray(i,:) 66 | enddo 67 | 68 | write(*,*)'Permuted matrix' 69 | 70 | #if (_METIS==1) 71 | perm=crs%getordering(bglvl=0) 72 | #else 73 | perm=(/(i,i=1,crs%getdim(1))/) 74 | #endif 75 | iarray=0 76 | do i=1,crs%getdim(1) 77 | do j=1,crs%getdim(2) 78 | val=crs%get(perm(i),perm(j)) 79 | if(val.ne.0.)iarray(i,j)=1 80 | enddo 81 | enddo 82 | 83 | do i=1,crs%getdim(1) 84 | write(*,'(10000(i2))')iarray(i,:) 85 | enddo 86 | 87 | !!!!!! 88 | 89 | call crs%spainv() 90 | 91 | call crs%printsquare() 92 | 93 | 94 | !!!!!! 95 | crs=coo 96 | 97 | call crs%sort() 98 | 99 | #if (_METIS==1) 100 | perm=crs%getordering(bglvl=0) 101 | #else 102 | perm=(/(i,i=1,crs%getdim(1))/) 103 | #endif 104 | call crs%setpermutation(perm) 105 | call crs%printstats() 106 | 107 | print*,'ord ',perm 108 | 109 | allocate(x(crs%getdim(1)),y(crs%getdim(1))) 110 | x=1.;y=1. 111 | 112 | call crs%solve(x,y) 113 | 114 | print*,'x ',x 115 | print*,'y ',y 116 | 117 | 118 | end program 119 | -------------------------------------------------------------------------------- /examples/test7.f90: -------------------------------------------------------------------------------- 1 | program test7 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | #if (_METIS==1) 8 | use modmetis,only:METIS_CTYPE_SHEM 9 | #endif 10 | use modsparse 11 | implicit none 12 | integer(kind=int32)::nrow 13 | integer(kind=int32)::row 14 | integer(kind=int32)::col 15 | integer(kind=int32)::iunit, istat 16 | integer(kind=int32)::i,j 17 | integer(kind=int32),allocatable::iarray(:,:) 18 | integer(kind=int32),allocatable::perm(:) 19 | real(kind=wp)::val 20 | real(kind=wp),allocatable::x(:),y(:) 21 | real(kind=wp),allocatable::x2(:,:),y2(:,:) 22 | real(kind=wp),allocatable::xx(:) 23 | logical::lup=.false. 24 | type(coosparse)::coo 25 | type(crssparse)::crs 26 | type(crssparse)::crs1 27 | 28 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 29 | !COO UPPER 30 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 31 | read(iunit,*) nrow 32 | 33 | coo=coosparse(5,lupper=.true.) 34 | 35 | do 36 | read(iunit,*,iostat=istat) row,col,val 37 | if(istat.ne.0)exit 38 | call coo%add(row,col,val) 39 | end do 40 | close(iunit) 41 | 42 | call coo%add(5,5,1._wp) 43 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 44 | !CSR UPPER 45 | crs=coo 46 | 47 | call crs%printsquare() 48 | 49 | !perm=crs%getordering() 50 | #if (_METIS==1) 51 | perm=crs%getordering(compress=1,ctype=METIS_CTYPE_SHEM) 52 | #else 53 | perm=(/(i,i=1,crs%getdim(1))/) 54 | #endif 55 | 56 | call crs%printstats() 57 | 58 | call crs%setpermutation(perm) 59 | call crs%printstats() 60 | 61 | allocate(x(crs%getdim(1)),y(crs%getdim(1))) 62 | do i=1,crs%getdim(1) 63 | y(i)=i 64 | enddo 65 | print*,'y=[',y,' ]' 66 | 67 | x=0._wp 68 | call crs%solve(x,y) 69 | 70 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 71 | !CSR UPPER 72 | call coo%add(5,5,10._wp) 73 | call coo%add(2,5,11._wp) 74 | call coo%add(5,2,11._wp) 75 | call coo%add(1,5,11._wp) 76 | call coo%add(5,1,11._wp) 77 | 78 | do i=1,coo%getdim(1) 79 | call coo%add(i,i,1._wp) 80 | enddo 81 | 82 | crs1=coo 83 | 84 | call crs1%printsquare() 85 | 86 | #if (_METIS==1) 87 | perm=crs1%getordering(compress=1,ctype=METIS_CTYPE_SHEM) 88 | #else 89 | perm=(/(i,i=1,crs1%getdim(1))/) 90 | #endif 91 | 92 | call crs1%printstats() 93 | 94 | call crs1%setpermutation(perm) 95 | call crs1%printstats() 96 | 97 | allocate(xx(crs1%getdim(1))) 98 | do i=1,crs1%getdim(1) 99 | y(i)=i 100 | enddo 101 | 102 | xx=0._wp 103 | call crs1%solve(xx,y) 104 | 105 | do i=1,crs1%getdim(1) 106 | write(*,*)x(i),xx(i) 107 | enddo 108 | 109 | 110 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 111 | !CSR UPPER 112 | write(*,'(a)')' Multiple RHS' 113 | 114 | allocate(x2(crs1%getdim(1),5),y2(crs1%getdim(1),5)) 115 | do j=1,5 116 | do i=1,crs1%getdim(1) 117 | y2(i,j)=real(i,kind=wp)/j 118 | enddo 119 | enddo 120 | 121 | x2=0._wp 122 | call crs1%solve(x2,y2) 123 | 124 | do i=1,crs1%getdim(1) 125 | write(*,*)x2(i,:) 126 | enddo 127 | 128 | end program 129 | -------------------------------------------------------------------------------- /examples/test8.f90: -------------------------------------------------------------------------------- 1 | program test1 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::nrow 10 | integer(kind=int32)::row 11 | integer(kind=int32)::col 12 | integer(kind=int32)::iunit, istat 13 | real(kind=wp)::val 14 | logical::lup=.false. 15 | type(coosparse)::coo 16 | type(crssparse)::crs,crs1 17 | 18 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 19 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 20 | read(iunit,*) nrow 21 | 22 | coo=coosparse(8,5) 23 | 24 | do 25 | read(iunit,*,iostat=istat) row,col,val 26 | if(istat.ne.0)exit 27 | call coo%add(row,col,val) 28 | end do 29 | close(iunit) 30 | 31 | call coo%printstats() 32 | call coo%print() 33 | call coo%printsquare() 34 | !call coo%print(lint=.false.) 35 | 36 | crs=coo 37 | call crs%printstats() 38 | call crs%print() 39 | call crs%printsquare() 40 | 41 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 42 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 43 | read(iunit,*) nrow 44 | 45 | coo=coosparse(8,5) 46 | 47 | do 48 | read(iunit,*,iostat=istat) row,col,val 49 | if(istat.ne.0)exit 50 | call coo%add(row+2,col+2,val) 51 | end do 52 | close(iunit) 53 | 54 | call coo%printstats() 55 | call coo%print() 56 | call coo%printsquare() 57 | !call coo%print(lint=.false.) 58 | 59 | crs=coo 60 | call crs%printstats() 61 | call crs%print() 62 | call crs%printsquare() 63 | 64 | 65 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 66 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 67 | read(iunit,*) nrow 68 | 69 | coo=coosparse(8) 70 | 71 | do 72 | read(iunit,*,iostat=istat) row,col,val 73 | if(istat.ne.0)exit 74 | call coo%add(row,col,val) 75 | call coo%add(col,row,val) 76 | end do 77 | close(iunit) 78 | 79 | call coo%printstats() 80 | call coo%print() 81 | call coo%printsquare() 82 | !call coo%print(lint=.false.) 83 | 84 | crs=coo 85 | call crs%printstats() 86 | call crs%print() 87 | call crs%printsquare() 88 | 89 | 90 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 91 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 92 | read(iunit,*) nrow 93 | 94 | coo=coosparse(8) 95 | 96 | do 97 | read(iunit,*,iostat=istat) row,col,val 98 | if(istat.ne.0)exit 99 | call coo%add(row+2,col+2,val) 100 | call coo%add(col+2,row+2,val) 101 | end do 102 | close(iunit) 103 | 104 | call coo%printstats() 105 | call coo%print() 106 | call coo%printsquare() 107 | !call coo%print(lint=.false.) 108 | 109 | crs=coo 110 | call crs%printstats() 111 | call crs%print() 112 | call crs%printsquare() 113 | 114 | 115 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 116 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 117 | read(iunit,*) nrow 118 | 119 | coo=coosparse(5,8) 120 | 121 | do 122 | read(iunit,*,iostat=istat) row,col,val 123 | if(istat.ne.0)exit 124 | call coo%add(row,col,val) 125 | end do 126 | close(iunit) 127 | 128 | call coo%printstats() 129 | call coo%print() 130 | call coo%printsquare() 131 | !call coo%print(lint=.false.) 132 | 133 | crs=coo 134 | call crs%printstats() 135 | call crs%print() 136 | call crs%printsquare() 137 | 138 | 139 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 140 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 141 | read(iunit,*) nrow 142 | 143 | coo=coosparse(5,8) 144 | 145 | do 146 | read(iunit,*,iostat=istat) row,col,val 147 | if(istat.ne.0)exit 148 | call coo%add(row+2,col+2,val) 149 | call coo%add(col+2,row+2,val) 150 | end do 151 | close(iunit) 152 | 153 | call coo%printstats() 154 | call coo%print() 155 | call coo%printsquare() 156 | !call coo%print(lint=.false.) 157 | 158 | crs=coo 159 | call crs%printstats() 160 | call crs%print() 161 | call crs%printsquare() 162 | 163 | 164 | 165 | 166 | end program 167 | -------------------------------------------------------------------------------- /examples/test9.f90: -------------------------------------------------------------------------------- 1 | program test9 2 | #if (_DP==0) 3 | use iso_fortran_env,only:int32,int64,wp=>real32 4 | #else 5 | use iso_fortran_env,only:int32,int64,wp=>real64 6 | #endif 7 | use modsparse 8 | implicit none 9 | integer(kind=int32)::i 10 | integer(kind=int32)::nrow 11 | integer(kind=int32)::row 12 | integer(kind=int32)::col 13 | integer(kind=int32)::iunit, istat 14 | real(kind=wp)::val 15 | real(kind=wp),allocatable::x(:),y(:),y1(:) 16 | real(kind=wp),allocatable::xa(:,:),ya(:,:),ya1(:,:) 17 | logical::lup=.false. 18 | type(coosparse)::coo 19 | type(crssparse)::crs 20 | 21 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 22 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 23 | read(iunit,*) nrow 24 | 25 | coo=coosparse(nrow) 26 | 27 | do 28 | read(iunit,*,iostat=istat) row,col,val 29 | if(istat.ne.0)exit 30 | call coo%add(row,col,val) 31 | end do 32 | close(iunit) 33 | 34 | 35 | allocate(x(coo%getdim(2)),y(coo%getdim(1)),y1(coo%getdim(1))) 36 | allocate(xa(coo%getdim(2),3),ya(coo%getdim(1),3),ya1(coo%getdim(1),3)) 37 | 38 | x(:) = [(i,i=1,size(x,1))] 39 | xa = 3 40 | xa(:,1) = [(i,i=1,size(x,1))] 41 | 42 | call coo%printstats() 43 | call coo%print() 44 | call coo%printsquare() 45 | !call coo%print(lint=.false.) 46 | 47 | crs=coo 48 | call crs%printstats() 49 | call crs%print() 50 | call crs%printsquare() 51 | 52 | call coo%mult(1._wp,'n',x,2.5_wp,y) 53 | call crs%mult(1._wp,'n',x,2.5_wp,y1) 54 | print*,'sum ',sum(abs(y-y1)) 55 | 56 | call coo%mult(1._wp,'n',xa,2.5_wp,ya) 57 | call crs%mult(1._wp,'n',xa,2.5_wp,ya1) 58 | print*,'sum ',sum(abs(ya-ya1)) 59 | 60 | deallocate(x,xa,y,ya,y1,ya1) 61 | 62 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 63 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 64 | read(iunit,*) nrow 65 | 66 | coo=coosparse(nrow,lupper=.true.) 67 | 68 | do 69 | read(iunit,*,iostat=istat) row,col,val 70 | if(istat.ne.0)exit 71 | call coo%add(row,col,val) 72 | end do 73 | close(iunit) 74 | 75 | 76 | allocate(x(coo%getdim(2)),y(coo%getdim(1))) 77 | allocate(xa(coo%getdim(2),3),ya(coo%getdim(1),3)) 78 | 79 | x(:) = [(i,i=1,size(x,1))] 80 | xa = 3 81 | xa(:,1) = [(i,i=1,size(x,1))] 82 | 83 | call coo%printstats() 84 | call coo%print() 85 | call coo%printsquare() 86 | !call coo%print(lint=.false.) 87 | 88 | crs=coo 89 | call crs%sort() 90 | call crs%printstats() 91 | call crs%print() 92 | call crs%printsquare() 93 | 94 | y=1.7 95 | y1=y 96 | call coo%mult(1._wp,'n',x,2.5_wp,y) 97 | call crs%mult(1._wp,'n',x,2.5_wp,y1) 98 | print*,'sum ',sum(abs(y-y1)) 99 | 100 | ya=1.7 101 | ya1=ya 102 | call coo%mult(1._wp,'n',xa,2.5_wp,ya) 103 | call crs%mult(1._wp,'n',xa,2.5_wp,ya1) 104 | print*,'sum ',sum(abs(ya-ya1)) 105 | 106 | 107 | deallocate(x,xa,y,ya,y1,ya1) 108 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 109 | open(newunit=iunit,file='crsinput.ascii',status='old',action='read') 110 | read(iunit,*) nrow 111 | 112 | coo=coosparse(nrow,lupper=.true.) 113 | 114 | call coo%setsymmetric() 115 | 116 | do 117 | read(iunit,*,iostat=istat) row,col,val 118 | if(istat.ne.0)exit 119 | call coo%add(row,col,val) 120 | end do 121 | close(iunit) 122 | 123 | 124 | allocate(x(coo%getdim(2)),y(coo%getdim(1))) 125 | allocate(xa(coo%getdim(2),3),ya(coo%getdim(1),3)) 126 | 127 | x(:) = [(i,i=1,size(x,1))] 128 | xa = 3 129 | xa(:,1) = [(i,i=1,size(x,1))] 130 | 131 | call coo%printstats() 132 | call coo%print() 133 | call coo%printsquare() 134 | !call coo%print(lint=.false.) 135 | 136 | crs=coo 137 | call crs%sort() 138 | call crs%printstats() 139 | call crs%print() 140 | call crs%printsquare() 141 | 142 | y=1.7 143 | y1=y 144 | call coo%mult(1._wp,'n',x,2.5_wp,y) 145 | call crs%mult(1._wp,'n',x,2.5_wp,y1) 146 | print*,'sum ',sum(abs(y-y1)) 147 | 148 | ya=1.7 149 | ya1=ya 150 | call coo%mult(1._wp,'n',xa,2.5_wp,ya) 151 | call crs%mult(1._wp,'n',xa,2.5_wp,ya1) 152 | print*,'sum ',sum(abs(ya-ya1)) 153 | 154 | end program 155 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "libsparse" 2 | version = "0.0.0" 3 | license = "MIT" 4 | author = "Jeremie Vandenplas" 5 | maintainer = "jvdp1" 6 | copyright = "Copyright 2021, Jeremie Vandenplas" 7 | 8 | 9 | [fortran] 10 | implicit-typing = true 11 | implicit-external = true 12 | source-form = "default" 13 | 14 | 15 | [build] 16 | auto-executables = false 17 | auto-tests = false 18 | auto-examples = false 19 | external-modules = "mkl_pardiso" 20 | 21 | [dependencies] 22 | openmp = "*" 23 | 24 | [preprocess] 25 | [preprocess.cpp] 26 | suffixes = [".F90", ".f90"] 27 | macros = [ 28 | "_DP=1", 29 | "_METIS=1", 30 | "_PARDISO=1", 31 | "_SPAINV=1", 32 | "_VERBOSE=0" 33 | ] 34 | 35 | 36 | [install] 37 | library = false 38 | 39 | 40 | [[test]] 41 | name = "test_sparse" 42 | main = "test_sparse.f90" 43 | #link = ["mkl_gf_lp64", "mkl_gnu_thread", "mkl_core", "gomp", "pthread", "m", "dl", "metis"] 44 | link = ["mkl_blas95_lp64", "mkl_lapack95_lp64", "mkl_intel_lp64", "mkl_intel_thread", "mkl_core", "iomp5", "pthread", "m", "dl", "metis"] 45 | 46 | [test.dependencies] 47 | test-drive = {git = "https://github.com/fortran-lang/test-drive.git" } 48 | -------------------------------------------------------------------------------- /src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Based on test-drive. 2 | # License test-drive 3 | # SPDX-Identifier: Apache-2.0 OR MIT 4 | # 5 | # Licensed under either of Apache License, Version 2.0 or MIT license 6 | # at your option; you may not use this file except in compliance with 7 | # the License. 8 | # 9 | # Unless required by applicable law or agreed to in writing, software 10 | # distributed under the License is distributed on an "AS IS" BASIS, 11 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | # See the License for the specific language governing permissions and 13 | # limitations under the License. 14 | 15 | set(dir "${CMAKE_CURRENT_SOURCE_DIR}") 16 | 17 | list( 18 | APPEND srcs 19 | "${dir}/dgtrsm.f" 20 | "${dir}/modcommon.f90" 21 | "${dir}/modsparse_hash.f90" 22 | "${dir}/modrandom.f90" 23 | "${dir}/modspainv.f90" 24 | "${dir}/modsparse_coo.f90" 25 | "${dir}/modsparse_crs64.f90" 26 | "${dir}/modsparse_crs.f90" 27 | "${dir}/modsparse.f90" 28 | "${dir}/modsparse_gen.f90" 29 | "${dir}/modsparse_ll.f90" 30 | "${dir}/modsparse_metisgraph.f90" 31 | "${dir}/modsparse_mkl.f90" 32 | "${dir}/modvariablepardiso.f90" 33 | "${dir}/sgtrsm.f" 34 | "${dir}/smbfct.f" 35 | ) 36 | 37 | if(CMAKE_METIS_LIB) 38 | list( 39 | APPEND srcs 40 | "${dir}/modmetis.f90" 41 | ) 42 | endif() 43 | 44 | set(srcs "${srcs}" PARENT_SCOPE) 45 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # Makes libraries 2 | 3 | ifeq ($(PARDISOENABLE),1) 4 | OBJPARDISO = modvariablepardiso.o 5 | endif 6 | 7 | ifeq ($(METISENABLE),1) 8 | OBJMETIS = modmetis.o 9 | endif 10 | 11 | ifeq ($(SPAINVENABLE),1) 12 | OBJSPAINV = sgtrsm.o dgtrsm.o smbfct.o modspainv.o 13 | endif 14 | 15 | 16 | all: libsparse.a 17 | 18 | OBJ = modcommon.o \ 19 | modrandom.o \ 20 | $(OBJPARDISO) $(OBJMETIS) $(OBJSPAINV) \ 21 | modsparse_mkl.o modsparse_hash.o modsparse.o modsparse_gen.o modsparse_coo.o \ 22 | modsparse_crs64.o \ 23 | modsparse_crs.o modsparse_ll.o modsparse_metisgraph.o 24 | 25 | libsparse.a: $(OBJ) 26 | ar cr libsparse.a $(OBJ) 27 | 28 | %.o: %.f90 29 | $(FC) -c $(FFLAGS) $(DEBUG) $< 30 | 31 | %.o: %.f 32 | $(FC) -c $(FFLAGS) $(DEBUG) $< 33 | 34 | 35 | #dependencies 36 | modsparse_coo.o: modsparse.o modsparse_hash.o 37 | modsparse_crs.o: modsparse_mkl.o modsparse.o $(OBJSPAINV) $(OBJPARDISO) $(OBJMETIS) 38 | modsparse_crs64.o: modsparse.o $(OBJPARDISO) 39 | modspainv.o: modcommon.o modsparse_mkl.o 40 | modsparse.o: $(OBJPARDISO) 41 | modsparse_gen.o: modsparse.o 42 | modsparse_ll.o: modsparse.o 43 | modsparse_metisgraph.o: modsparse.o 44 | modvariablepardiso.o: modsparse_mkl.o 45 | 46 | 47 | 48 | 49 | clean: 50 | rm -fv *.o *.optrpt *.a *.mod *.smod 51 | 52 | cleanlib: 53 | rm -fv *.a 54 | -------------------------------------------------------------------------------- /src/dgtrsm.f: -------------------------------------------------------------------------------- 1 | CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc 2 | C Modified by J. Vandenplas (2019/10/28) to allow semi-positive definite 3 | C matrix 4 | CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc 5 | C 6 | C =========== DOCUMENTATION =========== 7 | C 8 | C Online html documentation available at 9 | C http://www.netlib.org/lapack/explore-html/ 10 | C 11 | C Definition: 12 | C =========== 13 | C 14 | C SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 15 | C 16 | C .. Scalar Arguments .. 17 | C DOUBLE PRECISION ALPHA 18 | C INTEGER LDA,LDB,M,N 19 | C CHARACTER DIAG,SIDE,TRANSA,UPLO 20 | C .. 21 | C .. Array Arguments .. 22 | C DOUBLE PRECISION A(LDA,*),B(LDB,*) 23 | C .. 24 | C 25 | C 26 | C> \par Purpose: 27 | C ============= 28 | C> 29 | C> \verbatim 30 | C> 31 | C> DTRSM solves one of the matrix equations 32 | C> 33 | C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, 34 | C> 35 | C> where alpha is a scalar, X and B are m by n matrices, A is a unit, 36 | Cor 37 | C> non-unit, upper or lower triangular matrix and op( A ) is one 38 | Cof 39 | C> 40 | C> op( A ) = A or op( A ) = A**T. 41 | C> 42 | C> The matrix X is overwritten on B. 43 | C> \endverbatim 44 | C 45 | C Arguments: 46 | C ========== 47 | C 48 | C> \param[in] SIDE 49 | C> \verbatim 50 | C> SIDE is CHARACTER*1 51 | C> On entry, SIDE specifies whether op( A ) appears on the 52 | Cleft 53 | C> or right of X as follows: 54 | C> 55 | C> SIDE = 'L' or 'l' op( A )*X = alpha*B. 56 | C> 57 | C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. 58 | C> \endverbatim 59 | C> 60 | C> \param[in] UPLO 61 | C> \verbatim 62 | C> UPLO is CHARACTER*1 63 | C> On entry, UPLO specifies whether the matrix A is an upper 64 | Cor 65 | C> lower triangular matrix as follows: 66 | C> 67 | C> UPLO = 'U' or 'u' A is an upper triangular matrix. 68 | C> 69 | C> UPLO = 'L' or 'l' A is a lower triangular matrix. 70 | C> \endverbatim 71 | C> 72 | C> \param[in] TRANSA 73 | C> \verbatim 74 | C> TRANSA is CHARACTER*1 75 | C> On entry, TRANSA specifies the form of op( A ) to be used 76 | Cin 77 | C> the matrix multiplication as follows: 78 | C> 79 | C> TRANSA = 'N' or 'n' op( A ) = A. 80 | C> 81 | C> TRANSA = 'T' or 't' op( A ) = A**T. 82 | C> 83 | C> TRANSA = 'C' or 'c' op( A ) = A**T. 84 | C> \endverbatim 85 | C> 86 | C> \param[in] DIAG 87 | C> \verbatim 88 | C> DIAG is CHARACTER*1 89 | C> On entry, DIAG specifies whether or not A is unit 90 | Ctriangular 91 | C> as follows: 92 | C> 93 | C> DIAG = 'U' or 'u' A is assumed to be unit triangular. 94 | C> 95 | C> DIAG = 'N' or 'n' A is not assumed to be unit 96 | C> triangular. 97 | C> \endverbatim 98 | C> 99 | C> \param[in] M 100 | C> \verbatim 101 | C> M is INTEGER 102 | C> On entry, M specifies the number of rows of B. M must be 103 | Cat 104 | C> least zero. 105 | C> \endverbatim 106 | C> 107 | C> \param[in] N 108 | C> \verbatim 109 | C> N is INTEGER 110 | C> On entry, N specifies the number of columns of B. N must 111 | Cbe 112 | C> at least zero. 113 | C> \endverbatim 114 | C> 115 | C> \param[in] ALPHA 116 | C> \verbatim 117 | C> ALPHA is DOUBLE PRECISION. 118 | C> On entry, ALPHA specifies the scalar alpha. When alpha 119 | Cis 120 | C> zero then A is not referenced and B need not be set 121 | Cbefore 122 | C> entry. 123 | C> \endverbatim 124 | C> 125 | C> \param[in] A 126 | C> \verbatim 127 | C> A is DOUBLE PRECISION array, dimension ( LDA, k ), 128 | C> where k is m when SIDE = 'L' or 'l' 129 | C> and k is n when SIDE = 'R' or 'r'. 130 | C> Before entry with UPLO = 'U' or 'u', the leading k by 131 | Ck 132 | C> upper triangular part of the array A must contain the 133 | Cupper 134 | C> triangular matrix and the strictly lower triangular part 135 | Cof 136 | C> A is not referenced. 137 | C> Before entry with UPLO = 'L' or 'l', the leading k by 138 | Ck 139 | C> lower triangular part of the array A must contain the 140 | Clower 141 | C> triangular matrix and the strictly upper triangular part 142 | Cof 143 | C> A is not referenced. 144 | C> Note that when DIAG = 'U' or 'u', the diagonal elements 145 | Cof 146 | C> A are not referenced either, but are assumed to be 147 | Cunity. 148 | C> \endverbatim 149 | C> 150 | C> \param[in] LDA 151 | C> \verbatim 152 | C> LDA is INTEGER 153 | C> On entry, LDA specifies the first dimension of A as 154 | Cdeclared 155 | C> in the calling (sub) program. When SIDE = 'L' or 'l' 156 | Cthen 157 | C> LDA must be at least max( 1, m ), when SIDE = 'R' or 158 | C'r' 159 | C> then LDA must be at least max( 1, n ). 160 | C> \endverbatim 161 | C> 162 | C> \param[in,out] B 163 | C> \verbatim 164 | C> B is DOUBLE PRECISION array, dimension ( LDB, N ) 165 | C> Before entry, the leading m by n part of the array B 166 | Cmust 167 | C> contain the right-hand side matrix B, and on exit 168 | Cis 169 | C> overwritten by the solution matrix X. 170 | C> \endverbatim 171 | C> 172 | C> \param[in] LDB 173 | C> \verbatim 174 | C> LDB is INTEGER 175 | C> On entry, LDB specifies the first dimension of B as 176 | Cdeclared 177 | C> in the calling (sub) program. LDB must be at 178 | Cleast 179 | C> max( 1, m ). 180 | C> \endverbatim 181 | C 182 | C Authors: 183 | C ======== 184 | C 185 | C> \author Univ. of Tennessee 186 | C> \author Univ. of California Berkeley 187 | C> \author Univ. of Colorado Denver 188 | C> \author NAG Ltd. 189 | C 190 | C> \date December 2016 191 | C 192 | C> \ingroup double_blas_level3 193 | C 194 | C> \par Further Details: 195 | C ===================== 196 | C> 197 | C> \verbatim 198 | C> 199 | C> Level 3 Blas routine. 200 | C> 201 | C> 202 | C> -- Written on 8-February-1989. 203 | C> Jack Dongarra, Argonne National Laboratory. 204 | C> Iain Duff, AERE Harwell. 205 | C> Jeremy Du Croz, Numerical Algorithms Group Ltd. 206 | C> Sven Hammarling, Numerical Algorithms Group Ltd. 207 | C> \endverbatim 208 | C> 209 | C ===================================================================== 210 | SUBROUTINE dgtrsm(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 211 | C 212 | C -- Reference BLAS level3 routine (version 3.7.0) -- 213 | C -- Reference BLAS is a software package provided by Univ. of 214 | C Tennessee, -- 215 | C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG 216 | C Ltd..-- 217 | C December 2016 218 | C 219 | C .. Scalar Arguments .. 220 | DOUBLE PRECISION ALPHA 221 | INTEGER LDA,LDB,M,N 222 | CHARACTER DIAG,SIDE,TRANSA,UPLO 223 | C .. 224 | C .. Array Arguments .. 225 | DOUBLE PRECISION A(lda,*),B(ldb,*) 226 | C .. 227 | C 228 | C ===================================================================== 229 | C 230 | C .. External Functions .. 231 | LOGICAL LSAME 232 | EXTERNAL lsame 233 | C .. 234 | C .. External Subroutines .. 235 | EXTERNAL xerbla 236 | C .. 237 | C .. Intrinsic Functions .. 238 | INTRINSIC max 239 | C .. 240 | C .. Local Scalars .. 241 | DOUBLE PRECISION atmp 242 | DOUBLE PRECISION TEMP 243 | INTEGER I,INFO,J,K,NROWA 244 | LOGICAL LSIDE,NOUNIT,UPPER 245 | C .. 246 | C .. Parameters .. 247 | DOUBLE PRECISION ONE,ZERO 248 | DOUBLE PRECISION TOL 249 | parameter(one=1.0d+0,zero=0.0d+0) 250 | parameter(tol=1.0d-10) 251 | C .. 252 | C 253 | C Test the input parameters. 254 | C 255 | lside = lsame(side,'L') 256 | IF (lside) THEN 257 | nrowa = m 258 | ELSE 259 | nrowa = n 260 | END IF 261 | nounit = lsame(diag,'N') 262 | upper = lsame(uplo,'U') 263 | C 264 | info = 0 265 | IF ((.NOT.lside) .AND. (.NOT.lsame(side,'R'))) THEN 266 | info = 1 267 | ELSE IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN 268 | info = 2 269 | ELSE IF ((.NOT.lsame(transa,'N')) .AND. 270 | + (.NOT.lsame(transa,'T')) .AND. 271 | + (.NOT.lsame(transa,'C'))) THEN 272 | info = 3 273 | ELSE IF ((.NOT.lsame(diag,'U')) .AND. (.NOT.lsame(diag,'N')))THEN 274 | info = 4 275 | ELSE IF (m.LT.0) THEN 276 | info = 5 277 | ELSE IF (n.LT.0) THEN 278 | info = 6 279 | ELSE IF (lda.LT.max(1,nrowa)) THEN 280 | info = 9 281 | ELSE IF (ldb.LT.max(1,m)) THEN 282 | info = 11 283 | END IF 284 | IF (info.NE.0) THEN 285 | CALL xerbla('DTRSM ',info) 286 | RETURN 287 | END IF 288 | C 289 | C Quick return if possible. 290 | C 291 | IF (m.EQ.0 .OR. n.EQ.0) RETURN 292 | C 293 | C And when alpha.eq.zero. 294 | C 295 | IF (alpha.EQ.zero) THEN 296 | DO 20 j = 1,n 297 | DO 10 i = 1,m 298 | b(i,j) = zero 299 | 10 CONTINUE 300 | 20 CONTINUE 301 | RETURN 302 | END IF 303 | C 304 | C Start the operations. 305 | C 306 | IF (lside) THEN 307 | IF (lsame(transa,'N')) THEN 308 | C 309 | C Form B := alpha*inv( A )*B. 310 | C 311 | IF (upper) THEN 312 | DO 60 j = 1,n 313 | IF (alpha.NE.one) THEN 314 | DO 30 i = 1,m 315 | b(i,j) = alpha*b(i,j) 316 | 30 CONTINUE 317 | END IF 318 | DO 50 k = m,1,-1 319 | IF (b(k,j).NE.zero) THEN 320 | ! IF (nounit) b(k,j) = b(k,j)/a(k,k) 321 | IF (nounit)then 322 | atmp=0.d0 323 | if(a(k,k).gt.tol)atmp=1.d0/a(k,k) 324 | b(k,j) = b(k,j)*atmp 325 | endif 326 | DO 40 i = 1,k - 1 327 | b(i,j) = b(i,j) - b(k,j)*a(i,k) 328 | 40 CONTINUE 329 | END IF 330 | 50 CONTINUE 331 | 60 CONTINUE 332 | ELSE 333 | DO 100 j = 1,n 334 | IF (alpha.NE.one) THEN 335 | DO 70 i = 1,m 336 | b(i,j) = alpha*b(i,j) 337 | 70 CONTINUE 338 | END IF 339 | DO 90 k = 1,m 340 | IF (b(k,j).NE.zero) THEN 341 | ! IF (nounit) b(k,j) = b(k,j)/a(k,k) 342 | IF (nounit)then 343 | atmp=0.d0 344 | if(a(k,k).gt.tol)atmp=1.d0/a(k,k) 345 | b(k,j) = b(k,j)*atmp 346 | endif 347 | DO 80 i = k + 1,m 348 | b(i,j) = b(i,j) - b(k,j)*a(i,k) 349 | 80 CONTINUE 350 | END IF 351 | 90 CONTINUE 352 | 100 CONTINUE 353 | END IF 354 | ELSE 355 | C 356 | C Form B := alpha*inv( A**T )*B. 357 | C 358 | IF (upper) THEN 359 | DO 130 j = 1,n 360 | DO 120 i = 1,m 361 | temp = alpha*b(i,j) 362 | DO 110 k = 1,i - 1 363 | temp = temp - a(k,i)*b(k,j) 364 | 110 CONTINUE 365 | ! IF (nounit) temp = temp/a(i,i) 366 | IF (nounit)then 367 | atmp=0.d0 368 | if(a(i,i).gt.tol)atmp=1.d0/a(i,i) 369 | temp = temp*atmp 370 | endif 371 | b(i,j) = temp 372 | 120 CONTINUE 373 | 130 CONTINUE 374 | ELSE 375 | DO 160 j = 1,n 376 | DO 150 i = m,1,-1 377 | temp = alpha*b(i,j) 378 | DO 140 k = i + 1,m 379 | temp = temp - a(k,i)*b(k,j) 380 | 140 CONTINUE 381 | ! IF (nounit) temp = temp/a(i,i) 382 | IF (nounit)then 383 | atmp=0.d0 384 | if(a(i,i).gt.tol)atmp=1.d0/a(i,i) 385 | temp = temp*atmp 386 | endif 387 | b(i,j) = temp 388 | 150 CONTINUE 389 | 160 CONTINUE 390 | END IF 391 | END IF 392 | ELSE 393 | IF (lsame(transa,'N')) THEN 394 | C 395 | C Form B := alpha*B*inv( A ). 396 | C 397 | IF (upper) THEN 398 | DO 210 j = 1,n 399 | IF (alpha.NE.one) THEN 400 | DO 170 i = 1,m 401 | b(i,j) = alpha*b(i,j) 402 | 170 CONTINUE 403 | END IF 404 | DO 190 k = 1,j - 1 405 | IF (a(k,j).NE.zero) THEN 406 | DO 180 i = 1,m 407 | b(i,j) = b(i,j) - a(k,j)*b(i,k) 408 | 180 CONTINUE 409 | END IF 410 | 190 CONTINUE 411 | IF (nounit) THEN 412 | ! temp = one/a(j,j) 413 | atmp=0.d0 414 | if(a(j,j).gt.tol)atmp=1.d0/a(j,j) 415 | temp = one*atmp 416 | DO 200 i = 1,m 417 | b(i,j) = temp*b(i,j) 418 | 200 CONTINUE 419 | END IF 420 | 210 CONTINUE 421 | ELSE 422 | DO 260 j = n,1,-1 423 | IF (alpha.NE.one) THEN 424 | DO 220 i = 1,m 425 | b(i,j) = alpha*b(i,j) 426 | 220 CONTINUE 427 | END IF 428 | DO 240 k = j + 1,n 429 | IF (a(k,j).NE.zero) THEN 430 | DO 230 i = 1,m 431 | b(i,j) = b(i,j) - a(k,j)*b(i,k) 432 | 230 CONTINUE 433 | END IF 434 | 240 CONTINUE 435 | IF (nounit) THEN 436 | ! temp = one/a(j,j) 437 | atmp=0.d0 438 | if(a(j,j).gt.tol)atmp=1.d0/a(j,j) 439 | temp = one*atmp 440 | DO 250 i = 1,m 441 | b(i,j) = temp*b(i,j) 442 | 250 CONTINUE 443 | END IF 444 | 260 CONTINUE 445 | END IF 446 | ELSE 447 | C 448 | C Form B := alpha*B*inv( A**T ). 449 | C 450 | IF (upper) THEN 451 | DO 310 k = n,1,-1 452 | IF (nounit) THEN 453 | ! temp = one/a(k,k) 454 | atmp=0.d0 455 | if(a(k,k).gt.tol)atmp=1.d0/a(k,k) 456 | temp = one*atmp 457 | DO 270 i = 1,m 458 | b(i,k) = temp*b(i,k) 459 | 270 CONTINUE 460 | END IF 461 | DO 290 j = 1,k - 1 462 | IF (a(j,k).NE.zero) THEN 463 | temp = a(j,k) 464 | DO 280 i = 1,m 465 | b(i,j) = b(i,j) - temp*b(i,k) 466 | 280 CONTINUE 467 | END IF 468 | 290 CONTINUE 469 | IF (alpha.NE.one) THEN 470 | DO 300 i = 1,m 471 | b(i,k) = alpha*b(i,k) 472 | 300 CONTINUE 473 | END IF 474 | 310 CONTINUE 475 | ELSE 476 | DO 360 k = 1,n 477 | IF (nounit) THEN 478 | ! temp = one/a(k,k) 479 | atmp=0.d0 480 | if(a(k,k).gt.tol)atmp=1.d0/a(k,k) 481 | temp = one*atmp 482 | DO 320 i = 1,m 483 | b(i,k) = temp*b(i,k) 484 | 320 CONTINUE 485 | END IF 486 | DO 340 j = k + 1,n 487 | IF (a(j,k).NE.zero) THEN 488 | temp = a(j,k) 489 | DO 330 i = 1,m 490 | b(i,j) = b(i,j) - temp*b(i,k) 491 | 330 CONTINUE 492 | END IF 493 | 340 CONTINUE 494 | IF (alpha.NE.one) THEN 495 | DO 350 i = 1,m 496 | b(i,k) = alpha*b(i,k) 497 | 350 CONTINUE 498 | END IF 499 | 360 CONTINUE 500 | END IF 501 | END IF 502 | END IF 503 | C 504 | RETURN 505 | C 506 | C End of DTRSM . 507 | C 508 | END 509 | -------------------------------------------------------------------------------- /src/modcommon.f90: -------------------------------------------------------------------------------- 1 | !> Module containing subroutines and functions common to all other modules 2 | 3 | module modcommon 4 | #if (_DP==0) 5 | use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real32 6 | #else 7 | use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real64 8 | #endif 9 | implicit none 10 | private 11 | public::progress 12 | 13 | contains 14 | 15 | !PUBLIC 16 | subroutine progress(i,n,un) 17 | integer(kind=int32),intent(in)::i,n 18 | integer(kind=int32),intent(in),optional::un 19 | 20 | integer(kind=int32)::unlog 21 | integer(kind=int32)::val 22 | integer(kind=int32)::step 23 | integer(kind=int32)::lastval=0 24 | 25 | unlog=output_unit 26 | if(present(un))unlog=un 27 | 28 | val=int(real(i)/real(n)*100.) 29 | 30 | step=10 31 | 32 | if(lastval+1.le.val/step)then 33 | write(unlog,'(2x,i0,"%")',advance='no')val 34 | lastval=val/step 35 | endif 36 | if(val.eq.100)then 37 | write(unlog,'(a/)',advance='yes') 38 | lastval=0 39 | endif 40 | 41 | end subroutine 42 | 43 | end module 44 | -------------------------------------------------------------------------------- /src/modmetis.f90: -------------------------------------------------------------------------------- 1 | !> Module containing interfaces for METIS 5 2 | 3 | !> @todo Currently supports only ordering. Should be extended to the other options. 4 | 5 | module modmetis 6 | !based on https://glaros.dtc.umn.edu/gkhome/node/877 7 | use iso_fortran_env,only:int32 8 | use iso_c_binding,only:c_int,c_ptr 9 | implicit none 10 | private 11 | public::metis_nodend,metis_setoptions,metis_checkerror 12 | 13 | integer(kind=c_int),parameter::METIS_NOPTIONS=40 14 | 15 | !options, possible values 16 | integer(kind=c_int),parameter,public::METIS_OPTION_PTYPE=0 ,METIS_PTYPE_RB=0,METIS_PTYPE_KWAY=1 17 | integer(kind=c_int),parameter,public::METIS_OPTION_OBJTYPE=1 ,METIS_OBJTYPE_CUT=1,METIS_OBJTYPE_VOL=1 18 | integer(kind=c_int),parameter,public::METIS_OPTION_CTYPE=2 ,METIS_CTYPE_RM=0,METIS_CTYPE_SHEM=1 19 | integer(kind=c_int),parameter,public::METIS_OPTION_IPTYPE=3 ,METIS_IPTYPE_GROW=0,METIS_IPTYPE_RANDOM=1& 20 | ,METIS_IPTYPE_EDGE=2,METIS_IPTYPE_NODE=3 21 | integer(kind=c_int),parameter,public::METIS_OPTION_RTYPE=4 ,METIS_RTYPE_FM=0,METIS_RTYPE_GREEDY=1& 22 | ,METIS_RTYPE_SEP2SIDED=2,METIS_RTYPE_SEP1SIDED=3 23 | integer(kind=c_int),parameter,public::METIS_OPTION_DBGLVL=5 ,METIS_DBG_INFO=1,METIS_DBG_TIME=2& 24 | ,METIS_DBG_COARSEN=4,METIS_DBG_REFINE=8& 25 | ,METIS_DBG_IPART=16,METIS_DBG_MOVEINFO=32,METIS_DBG_SEPINFO=64& 26 | ,METIS_DBG_CONNINFO=128,METIS_DBG_CONTIGINFO=256 27 | integer(kind=c_int),parameter,public::METIS_OPTION_NITER=6 !default: 10 28 | integer(kind=c_int),parameter,public::METIS_OPTION_NCUTS=7 !default: 1 29 | integer(kind=c_int),parameter,public::METIS_OPTION_SEED=8 30 | integer(kind=c_int),parameter,public::METIS_OPTION_NO2HOP=9 !0 or 1 31 | integer(kind=c_int),parameter,public::METIS_OPTION_MINCONN=10 !0 or 1 32 | integer(kind=c_int),parameter,public::METIS_OPTION_CONTIG=11 !0 or 1 33 | integer(kind=c_int),parameter,public::METIS_OPTION_COMPRESS=12 !0 or 1 34 | integer(kind=c_int),parameter,public::METIS_OPTION_CCORDER=13 !0 or 1 35 | integer(kind=c_int),parameter,public::METIS_OPTION_PFACTOR=14 36 | integer(kind=c_int),parameter,public::METIS_OPTION_NSEPS=15 !default: 1 37 | integer(kind=c_int),parameter,public::METIS_OPTION_UFACTOR=16 !default: 1 or 30 38 | integer(kind=c_int),parameter,public::METIS_OPTION_NUMBERING=17 !0 or 1 39 | 40 | !error values 41 | integer(kind=c_int),parameter::METIS_OK=1,METIS_ERROR_INPUT=-2,METIS_ERROR_MEMORY=-3,METIS_ERROR=-4 42 | 43 | interface 44 | function metis_setdefaultoptions(options) result(err) bind(C,name='METIS_SetDefaultOptions') 45 | import c_int,METIS_NOPTIONS 46 | integer(kind=c_int),intent(inout)::options(0:METIS_NOPTIONS) 47 | integer(kind=c_int)::err 48 | end function 49 | !METIS_NodND 50 | !OTPIONS Version 4 -> Version 5 51 | ![1] 1(RM) 2(HEM) 3(SHEM) -> CTYPE 52 | ![2] 1(edge-based) 2(node-based) -> ? 53 | ![3] 1(2-sided node) 2(1-sided node) -> RTYPE 54 | ![4] 0 55 | ![5] 0(no compress+no order) 1(compress) 2(order) 3(compress + order) -> COMPRESS + CCORDER 56 | ![6] remove vertices -> PFACTOR 57 | ![7] separators -> NSEPS 58 | function metis_nodend(nvtxs,xadj,adjncy,vwgt,options,perm,iperm) result(err) bind(C,name='METIS_NodeND') 59 | import c_int,c_ptr,METIS_NOPTIONS 60 | integer(kind=c_int),intent(in)::nvtxs 61 | integer(kind=c_int),intent(in)::xadj(*),adjncy(*) 62 | type(c_ptr),intent(in),value::vwgt 63 | integer(kind=c_int),intent(in)::options(0:METIS_NOPTIONS) !options is mandatory for Fortran when array start at pos 1 64 | integer(kind=c_int),intent(out)::perm(*),iperm(*) 65 | integer(kind=c_int)::err 66 | end function 67 | end interface 68 | 69 | contains 70 | 71 | function metis_setoptions(options& 72 | ,ptype,objtype,ctype,iptype,rtype,ncuts& 73 | ,nseps,niter,seed,minconn,no2hop,contig& 74 | ,compress,ccorder,pfactor,ufactor,dbglvl& 75 | ) result(err) 76 | integer(kind=c_int),allocatable,intent(out)::options(:) 77 | integer(kind=c_int),intent(in),optional::ptype,objtype,ctype,iptype,rtype,ncuts,& 78 | nseps,niter,seed,minconn,no2hop,& 79 | contig,compress,ccorder,pfactor,ufactor,dbglvl 80 | integer(kind=c_int)::err 81 | 82 | if(allocated(options))deallocate(options) 83 | allocate(options(0:METIS_NOPTIONS)) 84 | 85 | err=metis_setdefaultoptions(options) 86 | !DEFAULT 87 | options(METIS_OPTION_NUMBERING)=1 88 | 89 | !OPTIONAL 90 | if(present(ptype))options(METIS_OPTION_PTYPE)=ptype 91 | if(present(objtype))options(METIS_OPTION_OBJTYPE)=objtype 92 | if(present(ctype))options(METIS_OPTION_CTYPE)=ctype 93 | if(present(iptype))options(METIS_OPTION_IPTYPE)=iptype 94 | if(present(rtype))options(METIS_OPTION_RTYPE)=rtype 95 | if(present(ncuts))options(METIS_OPTION_NCUTS)=ncuts 96 | if(present(nseps))options(METIS_OPTION_NSEPS)=nseps 97 | if(present(niter))options(METIS_OPTION_NITER)=niter 98 | if(present(seed))options(METIS_OPTION_SEED)=seed 99 | if(present(minconn))options(METIS_OPTION_MINCONN)=minconn 100 | if(present(no2hop))options(METIS_OPTION_NO2HOP)=no2hop 101 | if(present(contig))options(METIS_OPTION_CONTIG)=contig 102 | if(present(compress))options(METIS_OPTION_COMPRESS)=compress 103 | if(present(ccorder))options(METIS_OPTION_CCORDER)=ccorder 104 | if(present(pfactor))options(METIS_OPTION_PFACTOR)=pfactor 105 | if(present(ufactor))options(METIS_OPTION_UFACTOR)=ufactor 106 | if(present(dbglvl))options(METIS_OPTION_DBGLVL)=dbglvl 107 | 108 | end function 109 | 110 | subroutine metis_checkerror(err,unlog) 111 | integer(kind=c_int),intent(in)::err 112 | integer(kind=int32),intent(in),optional::unlog 113 | 114 | integer(kind=int32)::un 115 | 116 | un=6 117 | if(present(unlog))un=unlog 118 | 119 | select case(err) 120 | case(METIS_OK) 121 | !write(un,'(/a/)')' METIS_OK' 122 | case(METIS_ERROR_INPUT) 123 | write(un,'(/a/)')' METIS_ERROR_INPUT' 124 | error stop 125 | case(METIS_ERROR_MEMORY) 126 | write(un,'(/a/)')' METIS_ERROR_MEMORY' 127 | error stop 128 | case(METIS_ERROR) 129 | write(un,'(/a/)')' METIS_ERROR' 130 | error stop 131 | case default 132 | write(un,'(/a/)')' UNKNOWN METIS_ERROR' 133 | error stop 134 | end select 135 | 136 | end subroutine 137 | 138 | end module 139 | -------------------------------------------------------------------------------- /src/modrandom.f90: -------------------------------------------------------------------------------- 1 | module modrandom 2 | #if (_DP==0) 3 | use, intrinsic:: iso_fortran_env, only: wp=>real32 4 | #else 5 | use, intrinsic:: iso_fortran_env, only: wp=>real64 6 | #endif 7 | implicit none 8 | private 9 | public :: setseed 10 | public :: rand_stduniform 11 | public :: rand_stdnormal 12 | 13 | real(wp), parameter :: pi = 4._wp * atan(1._wp) 14 | 15 | contains 16 | 17 | subroutine setseed(iseed) 18 | integer, intent(in) :: iseed 19 | 20 | integer :: n 21 | integer, allocatable :: seed(:) 22 | 23 | call random_seed(size = n) 24 | allocate(seed(n)) 25 | seed = iseed 26 | call random_seed(put = seed) 27 | deallocate(seed) 28 | 29 | end subroutine 30 | 31 | function rand_stduniform() result(var) 32 | real(wp) :: var 33 | 34 | call random_number(var) 35 | var = 1 - var 36 | 37 | end function 38 | 39 | function rand_stdnormal() result(var) 40 | real(wp) :: var 41 | 42 | real(wp) :: u1, u2 43 | 44 | u1 = rand_stduniform() 45 | u2 = rand_stduniform() 46 | 47 | var = sqrt(-2*log(u1)) * cos(2*pi*u2) 48 | 49 | end function 50 | 51 | 52 | end module 53 | -------------------------------------------------------------------------------- /src/modsparse_coo.f90: -------------------------------------------------------------------------------- 1 | submodule (modsparse) modsparse_coo 2 | use modsparse_hash, only:hashf,roundinguppower2 3 | !$ use omp_lib 4 | implicit none 5 | 6 | real(kind=real32),parameter::maxratiofilled_par=0.80 7 | 8 | contains 9 | 10 | !**CONSTRUCTOR 11 | module function constructor_coo(m,n,nel,lupper,unlog) result(sparse) 12 | type(coosparse)::sparse 13 | integer(kind=int32),intent(in)::m 14 | integer(kind=int32),intent(in),optional::n,unlog 15 | integer(kind=int64),intent(in),optional::nel 16 | logical,intent(in),optional::lupper 17 | 18 | call sparse%initialize('COO',m,m) 19 | 20 | if(present(n))sparse%dim2=n 21 | if(present(lupper))sparse%lupperstorage=lupper 22 | if(present(unlog))sparse%unlog=unlog 23 | 24 | sparse%lsymmetric=.false. 25 | 26 | sparse%filled=0_int64 27 | 28 | sparse%nel=roundinguppower2(100_int64) 29 | if(present(nel))sparse%nel=roundinguppower2(int(nel,int64)) 30 | allocate(sparse%ij(2,sparse%nel),sparse%a(sparse%nel)) 31 | sparse%ij=0 32 | sparse%a=0._wp 33 | 34 | end function 35 | 36 | module subroutine constructor_sub_coo(sparse,m,n,nel,lupper,unlog) 37 | class(coosparse),intent(out)::sparse 38 | integer(kind=int32),intent(in)::m 39 | integer(kind=int32),intent(in),optional::n,unlog 40 | integer(kind=int64),intent(in),optional::nel 41 | logical,intent(in),optional::lupper 42 | 43 | call sparse%initialize('COO',m,m) 44 | 45 | if(present(n))sparse%dim2=n 46 | if(present(lupper))sparse%lupperstorage=lupper 47 | if(present(unlog))sparse%unlog=unlog 48 | 49 | sparse%lsymmetric=.false. 50 | 51 | sparse%filled=0_int64 52 | 53 | sparse%nel=roundinguppower2(100_int64) 54 | if(present(nel))sparse%nel=roundinguppower2(int(nel,int64)) 55 | allocate(sparse%ij(2,sparse%nel)) 56 | sparse%ij=0 57 | allocate(sparse%a(sparse%nel)) 58 | sparse%a=0._wp 59 | 60 | end subroutine 61 | 62 | !**DESTROY 63 | module elemental subroutine destroy_coo(sparse) 64 | class(coosparse),intent(inout)::sparse 65 | 66 | call sparse%destroy_gen_gen() 67 | 68 | sparse%nel=-1_int64 69 | sparse%filled=-1_int64 70 | if(allocated(sparse%ij))deallocate(sparse%ij) 71 | if(allocated(sparse%a))deallocate(sparse%a) 72 | 73 | end subroutine 74 | 75 | !**DIAGONAL ELEMENTS 76 | module function diag_vect_coo(sparse) result(array) 77 | class(coosparse),intent(inout)::sparse 78 | real(kind=wp),allocatable::array(:) 79 | 80 | integer(kind=int32)::ndiag,i 81 | 82 | ndiag=min(sparse%dim1,sparse%dim2) 83 | 84 | allocate(array(ndiag)) 85 | array=0.0_wp 86 | 87 | do i=1,ndiag 88 | array(i)=sparse%get(i,i) 89 | enddo 90 | 91 | end function 92 | 93 | !**ADD ELEMENTS 94 | recursive module subroutine add_coo(sparse,row,col,val) 95 | class(coosparse),intent(inout)::sparse 96 | integer(kind=int32),intent(in)::row,col 97 | real(kind=wp),intent(in)::val 98 | 99 | integer(kind=int64)::hash,i8 100 | real(kind=real32),parameter::maxratiofilled=maxratiofilled_par 101 | real(kind=real32)::ratiofilled 102 | type(coosparse),allocatable::sptmp 103 | 104 | if(.not.validvalue_gen(sparse,row,col))return 105 | if(.not.validnonzero_gen(sparse,val))return 106 | if(sparse%lupperstorage.and..not.uppervalue_gen(row,col))return 107 | 108 | hash=hashf(row,col,sparse%ij,sparse%nel,sparse%filled,.false.) 109 | ratiofilled=real(sparse%filled)/real(sparse%nel) 110 | 111 | if(hash.eq.-1.or.ratiofilled.gt.maxratiofilled)then 112 | !matrix probably full, or nothing available within the n requested searches 113 | !1. Copy matrix 114 | !sptmp=coosparse(sparse%dim1,sparse%dim2,sparse%nel*2) !to avoid the copy through a temporary array 115 | allocate(sptmp);call sptmp%init(sparse%dim1,sparse%dim2,int(sparse%nel*1.5_real64, int64)) 116 | do i8=1_int64,sparse%nel 117 | call sptmp%add(sparse%ij(1,i8),sparse%ij(2,i8),sparse%a(i8)) 118 | enddo 119 | !2. reallocate matrix using move_alloc 120 | #if(_VERBOSE>0) 121 | write(sparse%unlog,'(2(a,i0))')' Current | New size COO: ',sparse%nel,' | ',sptmp%nel 122 | #endif 123 | sparse%nel=sptmp%nel 124 | sparse%filled=sptmp%filled 125 | if(allocated(sparse%ij))deallocate(sparse%ij) 126 | if(allocated(sparse%a))deallocate(sparse%a) 127 | call move_alloc(sptmp%ij,sparse%ij) 128 | call move_alloc(sptmp%a,sparse%a) 129 | call sptmp%destroy() 130 | !3. Search for a new address in the new matrix 131 | hash=hashf(row,col,sparse%ij,sparse%nel,sparse%filled,.false.) 132 | ratiofilled=real(sparse%filled)/real(sparse%nel) 133 | endif 134 | 135 | if(hash.gt.0_int64)then!.and.ratiofilled.le.maxratiofilled)then 136 | sparse%a(hash)=sparse%a(hash)+val 137 | else 138 | !is it possible? 139 | write(sparse%unlog,*)' ERROR: unexpected'!,__FILE__,__LINE__ 140 | error stop 141 | endif 142 | 143 | end subroutine 144 | 145 | !**GET ELEMENTS 146 | pure module function get_coo(sparse,row,col) result(val) 147 | class(coosparse),intent(in)::sparse 148 | integer(kind=int32),intent(in)::row,col 149 | real(kind=wp)::val 150 | 151 | integer(kind=int32)::trow,tcol 152 | integer(kind=int64)::hash 153 | 154 | val=0.0_wp 155 | 156 | trow=row 157 | tcol=col 158 | if(sparse%lupperstorage.and.sparse%lsymmetric.and.row.gt.col)then 159 | !swap row-col 160 | trow=col 161 | tcol=row 162 | endif 163 | 164 | hash=hashf(trow,tcol,sparse%ij,sparse%nel) 165 | 166 | if(hash.gt.0_int64)val=sparse%a(hash) 167 | 168 | end function 169 | 170 | !** GET MEMORY 171 | module function getmem_coo(sparse) result(getmem) 172 | class(coosparse),intent(in)::sparse 173 | integer(kind=int64)::getmem 174 | 175 | getmem=sparse%getmem_gen()+sizeof(sparse%nel)+sizeof(sparse%filled) 176 | if(allocated(sparse%ij))getmem=getmem+sizeof(sparse%ij) 177 | if(allocated(sparse%a))getmem=getmem+sizeof(sparse%a) 178 | 179 | end function 180 | 181 | !**EXTERNAL 182 | 183 | !**LOAD 184 | module function load_coo(namefile,unlog) result(sparse) 185 | type(coosparse)::sparse 186 | character(len=*),intent(in)::namefile 187 | integer(kind=int32),intent(in),optional::unlog 188 | 189 | integer(kind=int32)::un,dim1,dim2 190 | integer(kind=int64)::nonzero,nel 191 | logical::lupperstorage 192 | 193 | open(newunit=un,file=namefile,action='read',status='old',access='stream')!,buffered='yes') 194 | read(un)dim1 195 | if(dim1.ne.typecoo)then 196 | write(*,'(a)')' ERROR: the proposed file is not a COO file' 197 | error stop 198 | endif 199 | read(un)dim1 !int32 200 | read(un)dim2 !int32 201 | read(un)nonzero !int64 202 | read(un)nel !int64 203 | read(un)lupperstorage !logical 204 | 205 | if(present(unlog))then 206 | sparse=coosparse(dim1,dim2,nel,lupperstorage,unlog) 207 | else 208 | sparse=coosparse(dim1,dim2,nel,lupperstorage) 209 | endif 210 | 211 | sparse%filled=nonzero 212 | read(un)sparse%ij !int32 213 | read(un)sparse%a !wp 214 | close(un) 215 | 216 | end function 217 | 218 | !**MULTIPLICATIONS 219 | module subroutine multgenv_coo(sparse,alpha,trans,x,val,y) 220 | !Computes y=val*y+alpha*sparse(tranposition)*x 221 | class(coosparse),intent(in)::sparse 222 | real(kind=wp),intent(in)::val,alpha 223 | real(kind=wp),intent(in)::x(:) 224 | real(kind=wp),intent(out)::y(:) 225 | character(len=1),intent(in)::trans 226 | 227 | integer(kind=int64)::i 228 | integer(kind=int32)::j,k 229 | character(len=1)::matdescra(6) 230 | 231 | if(trans.eq.'N'.or.trans.eq.'n')then 232 | if(size(y).ne.sparse%getdim(1).or.size(x).ne.sparse%getdim(2))then 233 | write(sparse%unlog,'(a)')' ERROR (mult): wrong dimensions' 234 | error stop 235 | endif 236 | elseif(trans.eq.'T'.or.trans.eq.'t')then 237 | if(size(y).ne.sparse%getdim(2).or.size(x).ne.sparse%getdim(1))then 238 | write(sparse%unlog,'(a)')' ERROR (mult): wrong dimensions' 239 | error stop 240 | endif 241 | else 242 | write(sparse%unlog,'(a)')' ERROR (mult): wrong transposition' 243 | error stop 244 | endif 245 | 246 | matdescra='' 247 | 248 | if(sparse%lsymmetric.and.sparse%lupperstorage)then 249 | matdescra(1)='S' 250 | elseif(.not.sparse%lsymmetric.and.sparse%lupperstorage)then 251 | matdescra(1)='T' 252 | elseif(.not.sparse%lsymmetric.and..not.sparse%lupperstorage)then 253 | matdescra(1)='G' 254 | else 255 | write(sparse%unlog,'(a)')' ERROR (mult): unsupported format' 256 | call sparse%printstats 257 | error stop 258 | endif 259 | ! 260 | ! if(sparse%lupperstorage)then 261 | ! matdescra(2)='U' 262 | ! matdescra(3)='N' 263 | ! endif 264 | ! 265 | ! matdescra(4)='F' 266 | 267 | !don't forget transposition 268 | 269 | y = val * y 270 | select case(matdescra(1)) 271 | case('S') 272 | do i = 1, sparse%nel 273 | if(sparse%ij(1,i).eq.0)cycle 274 | j=sparse%ij(1,i) 275 | k=sparse%ij(2,i) 276 | y(j) = y(j) + alpha * sparse%a(i) * x(k) 277 | if(j.ne.k) y(k) = y(k) + alpha * sparse%a(i) * x(j) 278 | enddo 279 | case('T','G') 280 | if(trans.eq.'N'.or.trans.eq.'n')then 281 | do i = 1, sparse%nel 282 | if(sparse%ij(1,i).eq.0)cycle 283 | j=sparse%ij(1,i) 284 | k=sparse%ij(2,i) 285 | y(j) = y(j) + alpha * sparse%a(i) * x(k) 286 | enddo 287 | elseif(trans.eq.'T'.or.trans.eq.'t')then 288 | do i = 1, sparse%nel 289 | if(sparse%ij(1,i).eq.0)cycle 290 | j=sparse%ij(2,i) 291 | k=sparse%ij(1,i) 292 | y(j) = y(j) + alpha * sparse%a(i) * x(k) 293 | enddo 294 | endif 295 | case default 296 | write(sparse%unlog,'(a)')' ERROR (multbyv): unsupported format' 297 | error stop 298 | end select 299 | 300 | end subroutine 301 | 302 | module subroutine multgenm_coo(sparse,alpha,trans,x,val,y) 303 | !Computes y=val*y+alpha*sparse(tranposition)*x 304 | class(coosparse),intent(in)::sparse 305 | real(kind=wp),intent(in)::val,alpha 306 | real(kind=wp),intent(in)::x(:,:) 307 | real(kind=wp),intent(out)::y(:,:) 308 | character(len=1),intent(in)::trans 309 | 310 | integer(kind=int64)::i 311 | integer(kind=int32)::j,k 312 | character(len=1)::matdescra(6) 313 | 314 | if(trans.eq.'N'.or.trans.eq.'n')then 315 | if(size(y,1).ne.sparse%getdim(1).or.size(x,1).ne.sparse%getdim(2))then 316 | write(sparse%unlog,'(a)')' ERROR (mult): wrong dimensions' 317 | error stop 318 | endif 319 | elseif(trans.eq.'T'.or.trans.eq.'t')then 320 | if(size(y,1).ne.sparse%getdim(2).or.size(x,1).ne.sparse%getdim(1))then 321 | write(sparse%unlog,'(a)')' ERROR (mult): wrong dimensions' 322 | error stop 323 | endif 324 | else 325 | write(sparse%unlog,'(a)')' ERROR (mult): wrong transposition' 326 | error stop 327 | endif 328 | 329 | matdescra='' 330 | 331 | if(sparse%lsymmetric.and.sparse%lupperstorage)then 332 | matdescra(1)='S' 333 | elseif(.not.sparse%lsymmetric.and.sparse%lupperstorage)then 334 | matdescra(1)='T' 335 | elseif(.not.sparse%lsymmetric.and..not.sparse%lupperstorage)then 336 | matdescra(1)='G' 337 | else 338 | write(sparse%unlog,'(a)')' ERROR (mult): unsupported format' 339 | call sparse%printstats 340 | error stop 341 | endif 342 | ! 343 | ! if(sparse%lupperstorage)then 344 | ! matdescra(2)='U' 345 | ! matdescra(3)='N' 346 | ! endif 347 | ! 348 | ! matdescra(4)='F' 349 | 350 | y = val * y 351 | select case(matdescra(1)) 352 | case('S') 353 | do i = 1, sparse%nel 354 | if(sparse%ij(1,i).eq.0)cycle 355 | j=sparse%ij(1,i) 356 | k=sparse%ij(2,i) 357 | y(j,:) = y(j,:) + alpha * sparse%a(i) * x(k,:) 358 | if(j.ne.k) y(k,:) = y(k,:) + alpha * sparse%a(i) * x(j,:) 359 | enddo 360 | case('T','G') 361 | if(trans.eq.'N'.or.trans.eq.'n')then 362 | do i = 1, sparse%nel 363 | if(sparse%ij(1,i).eq.0)cycle 364 | j=sparse%ij(1,i) 365 | k=sparse%ij(2,i) 366 | y(j,:) = y(j,:) + alpha * sparse%a(i) * x(k,:) 367 | enddo 368 | elseif(trans.eq.'T'.or.trans.eq.'t')then 369 | do i = 1, sparse%nel 370 | if(sparse%ij(1,i).eq.0)cycle 371 | j=sparse%ij(2,i) 372 | k=sparse%ij(1,i) 373 | y(j,:) = y(j,:) + alpha * sparse%a(i) * x(k,:) 374 | enddo 375 | endif 376 | case default 377 | write(sparse%unlog,'(a)')' ERROR (multbyv): unsupported format' 378 | error stop 379 | end select 380 | 381 | end subroutine 382 | 383 | !**NUMBER OF ELEMENTS 384 | module function totalnumberofelements_coo(sparse) result(nel) 385 | class(coosparse),intent(in)::sparse 386 | integer(kind=int64)::nel 387 | 388 | nel=sparse%filled 389 | 390 | end function 391 | 392 | !**PRINT 393 | module subroutine print_coo(sparse,lint,output) 394 | class(coosparse),intent(in)::sparse 395 | integer(kind=int32),intent(in),optional::output 396 | logical,intent(in),optional::lint 397 | 398 | integer(kind=int32)::un,row,col 399 | integer(kind=int64)::i8 400 | real(kind=wp)::val 401 | character(len=30)::frm='(2(i0,1x),g0)' 402 | logical::linternal 403 | 404 | linternal=.true. 405 | if(present(lint))linternal=lint 406 | 407 | un=sparse%unlog 408 | if(present(output))un=output 409 | 410 | do i8=1,sparse%nel 411 | row=sparse%ij(1,i8) 412 | col=sparse%ij(2,i8) 413 | if(row.eq.0.and.col.eq.0)cycle 414 | val=sparse%a(i8) 415 | !if(.not.validvalue_gen(sparse,row,col))cycle !it should never happen 416 | !if(.not.validnonzero_gen(sparse,val))cycle !to print as internal 417 | write(un,frm)row,col,val 418 | if(.not.linternal.and.sparse%lupperstorage.and.sparse%lsymmetric.and.row.ne.col)then 419 | write(un,frm)col,row,val 420 | endif 421 | enddo 422 | 423 | end subroutine 424 | 425 | module subroutine print_idx_coo(sparse,lidx,lint,output) 426 | class(coosparse),intent(in)::sparse 427 | logical,intent(in)::lidx(:) 428 | integer(kind=int32),intent(in),optional::output 429 | logical,intent(in),optional::lint 430 | 431 | integer(kind=int32)::un,row,col 432 | integer(kind=int64)::i8 433 | real(kind=wp)::val 434 | character(len=30)::frm='(2(i0,1x),g0)' 435 | logical::linternal 436 | 437 | if(size(lidx).lt.sparse%getdim(1).or.size(lidx).lt.sparse%getdim(2))then 438 | error stop ' ERROR: the vector lidx is smaller than the smallest dimension of COO' 439 | endif 440 | 441 | linternal=.true. 442 | if(present(lint))linternal=lint 443 | 444 | un=sparse%unlog 445 | if(present(output))un=output 446 | 447 | do i8=1,sparse%nel 448 | row=sparse%ij(1,i8) 449 | col=sparse%ij(2,i8) 450 | if(row.eq.0.and.col.eq.0)cycle 451 | val=sparse%a(i8) 452 | !if(.not.validvalue_gen(sparse,row,col))cycle !it should never happen 453 | !if(.not.validnonzero_gen(sparse,val))cycle !to print as internal 454 | if(.not.lidx(row).or..not.lidx(col))cycle 455 | write(un,frm)row,col,val 456 | if(.not.linternal.and.sparse%lupperstorage.and.sparse%lsymmetric.and.row.ne.col)then 457 | write(un,frm)col,row,val 458 | endif 459 | enddo 460 | 461 | end subroutine 462 | 463 | module subroutine printsquare_coo(sparse,output) 464 | class(coosparse),intent(inout)::sparse 465 | integer(kind=int32),intent(in),optional::output 466 | 467 | integer(kind=int32)::i,j,un 468 | real(kind=wp),allocatable::tmp(:) 469 | 470 | un=sparse%unlog 471 | if(present(output))un=output 472 | 473 | allocate(tmp(sparse%dim2)) 474 | 475 | do i=1,sparse%dim1 476 | tmp=0._wp 477 | do j=1,sparse%dim2 478 | tmp(j)=sparse%get(i,j) 479 | enddo 480 | write(un,'(*(f9.3,1x))')tmp 481 | enddo 482 | 483 | deallocate(tmp) 484 | 485 | end subroutine 486 | 487 | !**SAVE 488 | module subroutine save_coo(sparse,namefile) 489 | class(coosparse),intent(in)::sparse 490 | character(len=*),intent(in)::namefile 491 | 492 | integer(kind=int32)::un 493 | 494 | open(newunit=un,file=namefile,action='write',status='replace',access='stream')!,buffered='yes') 495 | write(un)typecoo !int32 496 | write(un)sparse%dim1 !int32 497 | write(un)sparse%dim2 !int32 498 | write(un)sparse%nonzero() !int64 499 | write(un)sparse%nel !int64 500 | write(un)sparse%lupperstorage !logical 501 | write(un)sparse%ij !int32 502 | write(un)sparse%a !wp 503 | close(un) 504 | 505 | end subroutine 506 | 507 | !**SCALE ALL ENTRIES 508 | module subroutine scale_coo(sparse,val) 509 | class(coosparse),intent(inout)::sparse 510 | real(kind=wp),intent(in)::val 511 | sparse%a = sparse%a * val 512 | end subroutine 513 | 514 | !**SET ELEMENTS 515 | recursive module subroutine set_coo(sparse,row,col,val) 516 | !from add_coo 517 | class(coosparse),intent(inout)::sparse 518 | integer(kind=int32),intent(in)::row,col 519 | real(kind=wp),intent(in)::val 520 | 521 | integer(kind=int64)::hash,i8 522 | real(kind=real32),parameter::maxratiofilled=maxratiofilled_par 523 | real(kind=real32)::ratiofilled 524 | type(coosparse)::sptmp 525 | 526 | if(.not.validvalue_gen(sparse,row,col))return 527 | !if(.not.validnonzero_gen(sparse,val))return 528 | if(sparse%lupperstorage.and..not.uppervalue_gen(row,col))return 529 | 530 | hash=hashf(row,col,sparse%ij,sparse%nel,sparse%filled,.false.) 531 | ratiofilled=real(sparse%filled)/real(sparse%nel) 532 | 533 | if(hash.eq.-1.or.ratiofilled.gt.maxratiofilled)then 534 | !matrix probably full, or nothing available within the n requested searches 535 | !1. Copy matrix 536 | sptmp=coosparse(sparse%dim1,sparse%dim2,int(sparse%nel*1.5_real64, int64)) 537 | do i8=1_int64,sparse%nel 538 | call sptmp%add(sparse%ij(1,i8),sparse%ij(2,i8),sparse%a(i8)) 539 | enddo 540 | !2. reallocate matrix using move_alloc 541 | write(sparse%unlog,'(2(a,i0))')' Current | New size COO: ',sparse%nel,' | ',sptmp%nel 542 | sparse%nel=sptmp%nel 543 | sparse%filled=sptmp%filled 544 | if(allocated(sparse%ij))deallocate(sparse%ij) 545 | if(allocated(sparse%a))deallocate(sparse%a) 546 | call move_alloc(sptmp%ij,sparse%ij) 547 | call move_alloc(sptmp%a,sparse%a) 548 | call sptmp%destroy() 549 | !3. Search for a new address in the new matrix 550 | hash=hashf(row,col,sparse%ij,sparse%nel,sparse%filled,.false.) 551 | ratiofilled=real(sparse%filled)/real(sparse%nel) 552 | endif 553 | 554 | if(hash.gt.0_int64)then!.and.ratiofilled.le.maxratiofilled)then 555 | sparse%a(hash)=val 556 | else 557 | !is it possible? 558 | write(sparse%unlog,*)' ERROR: unexpected'!,__FILE__,__LINE__ 559 | stop 560 | endif 561 | 562 | end subroutine 563 | 564 | !**SOLVE 565 | 566 | !**SORT ARRAY 567 | 568 | !**SUBMATRIX 569 | module function submatrix_coo(sparse,startdim1,enddim1,startdim2,enddim2,lupper,unlog) result(subsparse) 570 | !Not programmed efficiently, but it should do the job 571 | class(coosparse),intent(in)::sparse 572 | type(coosparse)::subsparse 573 | integer(kind=int32),intent(in)::startdim1,enddim1,startdim2,enddim2 574 | integer(kind=int32),intent(in),optional::unlog 575 | logical,intent(in),optional::lupper 576 | 577 | integer(kind=int32)::i,j 578 | integer(kind=int64)::i8,nel 579 | logical::lincludediag,lupperstorage 580 | 581 | 582 | if(.not.validvalue_gen(sparse,startdim1,startdim2))return 583 | if(.not.validvalue_gen(sparse,enddim1,enddim2))return 584 | 585 | nel=10000 586 | 587 | !check if the submatrix include diagonal elements of sparse 588 | ! if yes -> lupperstorage 589 | ! if no -> .not.lupperstorage 590 | lincludediag=.false. 591 | firstdim: do i=startdim1,enddim1 592 | do j=startdim2,enddim2 593 | if(i.eq.j)then 594 | lincludediag=.true. 595 | exit firstdim 596 | endif 597 | enddo 598 | enddo firstdim 599 | 600 | lupperstorage=sparse%lupperstorage 601 | if(present(lupper))then 602 | lupperstorage=lupper 603 | else 604 | if(sparse%lupperstorage)then 605 | lupperstorage=.false. 606 | if(lincludediag)lupperstorage=.true. 607 | endif 608 | endif 609 | 610 | 611 | if(present(unlog))then 612 | subsparse=coosparse(enddim1-startdim1+1,enddim2-startdim2+1,int(nel,int64),lupperstorage,unlog) 613 | else 614 | subsparse=coosparse(enddim1-startdim1+1,enddim2-startdim2+1,int(nel,int64),lupperstorage) 615 | endif 616 | 617 | if(sparse%lupperstorage.eqv.lupperstorage.or.(sparse%lupperstorage.and..not.lincludediag))then 618 | ! upper -> upper || full -> full 619 | do i8=1,sparse%nel 620 | i=sparse%ij(1,i8) 621 | if(i.eq.0)cycle 622 | j=sparse%ij(2,i8) 623 | if((i.ge.startdim1.and.i.le.enddim1).and.(j.ge.startdim2.and.j.le.enddim2))then 624 | call subsparse%add(i-startdim1+1,j-startdim2+1,sparse%a(i8)) 625 | endif 626 | enddo 627 | elseif(sparse%lupperstorage.and..not.lupperstorage)then 628 | ! upper -> full 629 | do i8=1,sparse%nel 630 | i=sparse%ij(1,i8) 631 | if(i.eq.0)cycle 632 | j=sparse%ij(2,i8) 633 | if((i.ge.startdim1.and.i.le.enddim1).and.(j.ge.startdim2.and.j.le.enddim2))then 634 | call subsparse%add(i-startdim1+1,j-startdim2+1,sparse%a(i8)) 635 | endif 636 | ! if(i.ne.j)then 637 | ! if((j.ge.startdim1.and.j.le.enddim1).and.(i.ge.startdim2.and.i.le.enddim2))then 638 | ! call subsparse%add(j-startdim1+1,i-startdim2+1,sparse%a(i8)) 639 | ! endif 640 | ! endif 641 | enddo 642 | elseif(.not.sparse%lupperstorage.and.lupperstorage)then 643 | ! full -> upper 644 | do i8=1,sparse%nel 645 | i=sparse%ij(1,i8) 646 | if(i.eq.0)cycle 647 | j=sparse%ij(2,i8) 648 | if((j-startdim2+1.ge.i-startdim1+1).and.(i.ge.startdim1.and.i.le.enddim1).and.(j.ge.startdim2.and.j.le.enddim2))then 649 | call subsparse%add(i-startdim1+1,j-startdim2+1,sparse%a(i8)) 650 | endif 651 | enddo 652 | endif 653 | 654 | end function 655 | 656 | module subroutine submatrix_index_coo(sparse,subsparse,indvector,sizeblock,unlog) 657 | !Not programmed efficiently, but it should do the job 658 | class(coosparse),intent(in)::sparse 659 | type(coosparse),intent(out)::subsparse 660 | integer(kind=int32),intent(in)::indvector(:) 661 | integer(kind=int32),intent(in),optional::sizeblock 662 | integer(kind=int32),intent(in),optional::unlog 663 | 664 | integer(kind=int32)::i,j 665 | integer(kind=int32)::i_ 666 | integer(kind=int32)::ii,jj 667 | integer(kind=int64)::sizeblock_ 668 | integer(kind=int32)::startdim1,enddim1,startdim2,enddim2 669 | integer(kind=int64)::nel 670 | 671 | 672 | if(.not.validvalue_gen(sparse,minval(indvector),minval(indvector)))return 673 | if(.not.validvalue_gen(sparse,maxval(indvector),maxval(indvector)))return 674 | if(.not.sparse%lupperstorage)return 675 | 676 | nel = size(indvector) 677 | 678 | sizeblock_ = nel 679 | if(present(sizeblock))sizeblock_=sizeblock 680 | 681 | 682 | startdim1 = minval(indvector) 683 | enddim1 = maxval(indvector) 684 | startdim2 = minval(indvector) 685 | enddim2 = maxval(indvector) 686 | 687 | if(present(unlog))then 688 | call subsparse%init(size(indvector), size(indvector), nel, sparse%lupperstorage, unlog) 689 | else 690 | call subsparse%init(size(indvector), size(indvector), nel, sparse%lupperstorage) 691 | endif 692 | 693 | ! upper -> upper 694 | do i_ = 1, nel, sizeblock_ 695 | do i = i_, min(i_ + sizeblock_ - 1, size(indvector)) 696 | do j = i, min(i_ + sizeblock_ - 1, size(indvector)) 697 | ii = indvector(i) 698 | jj = indvector(j) 699 | if(ii.le.jj)then 700 | call subsparse%add(i, j, sparse%get(ii,jj)) 701 | else 702 | call subsparse%add(i, j, sparse%get(jj,ii)) 703 | endif 704 | enddo 705 | enddo 706 | enddo 707 | 708 | end subroutine 709 | 710 | end submodule 711 | -------------------------------------------------------------------------------- /src/modsparse_gen.f90: -------------------------------------------------------------------------------- 1 | submodule (modsparse) modsparse_gen 2 | !$ use omp_lib 3 | implicit none 4 | 5 | real(wp),parameter:: tolerance = 1.e-6 6 | 7 | contains 8 | 9 | !DESTROY 10 | !> @brief Subroutine to reset/destroy a generic object 11 | module elemental subroutine destroy_gen_gen(sparse) 12 | class(gen_sparse),intent(inout)::sparse 13 | 14 | sparse%namemat='UNKNOWN' 15 | sparse%dim1=-1 16 | sparse%dim2=-1 17 | sparse%unlog=output_unit 18 | sparse%lsorted=.false. 19 | sparse%lsymmetric=.false. 20 | sparse%lupperstorage=.false. 21 | if(allocated(sparse%perm))deallocate(sparse%perm) 22 | if(allocated(sparse%perm64))deallocate(sparse%perm64) 23 | 24 | end subroutine 25 | 26 | !**CONJUGATE GRADIENT 27 | module subroutine cg_gen(sparse,x,y,maxiter,tol) 28 | !sparse*x=y 29 | class(gen_sparse),intent(in)::sparse 30 | integer(kind=int32),intent(inout),optional::maxiter 31 | real(kind=wp),intent(inout)::x(:) 32 | real(kind=wp),intent(in)::y(:) 33 | real(kind=wp),intent(inout),optional::tol 34 | 35 | integer(kind=int32)::i,maxiter_ 36 | real(kind=wp)::r(size(x)) 37 | real(kind=wp)::p(size(x)) 38 | real(kind=wp)::Ap(size(x)) 39 | real(kind=wp)::rsnew,rsold,tol_,alpha 40 | real(kind=wp)::ynorm 41 | 42 | if(.not.sparse%issquare().or..not.sparse%lsymmetric& 43 | .or.size(x).ne.size(y)& 44 | .or.size(x).ne.sparse%getdim(2)& 45 | .or.size(y).ne.sparse%getdim(1)& 46 | )then 47 | write(sparse%unlog,'(a)')' ERROR: one of multiple arguments are not conform' 48 | error stop 49 | endif 50 | 51 | maxiter_ = min(1000,size(x)-1) 52 | if(present(maxiter))then 53 | if(maxiter.gt.0)maxiter_ = min(maxiter,size(x)-1) 54 | endif 55 | 56 | tol_ = tolerance 57 | if(present(tol))tol_=tol 58 | ynorm = norm2(y) 59 | tol_ = tol_ * ynorm 60 | 61 | Ap=0._wp 62 | call sparse%mult(1._wp,'n',x,0._wp,Ap) 63 | r = y - Ap 64 | p = r 65 | rsold = sum(r**2) 66 | 67 | do i=1, maxiter_ 68 | call sparse%mult(1._wp,'n',p,0._wp,Ap) 69 | alpha = rsold / dot_product(p,Ap) 70 | x = x + alpha * p 71 | r = r - alpha * Ap 72 | rsnew = sum(r**2) 73 | if(sqrt(rsnew) < tol_)exit 74 | p = r +(rsnew / rsold) * p 75 | rsold = rsnew 76 | enddo 77 | 78 | if(present(maxiter)) maxiter = i 79 | if(present(tol)) tol = sqrt(rsnew) / ynorm 80 | 81 | end subroutine 82 | 83 | !**GET ELEMENTS 84 | pure module function getdim_gen(sparse,dim1) result(dimget) 85 | class(gen_sparse),intent(in)::sparse 86 | integer(kind=int32),intent(in)::dim1 87 | integer(kind=int32)::dimget 88 | 89 | select case(dim1) 90 | case(1) 91 | dimget=sparse%dim1 92 | case(2) 93 | dimget=sparse%dim2 94 | case default 95 | dimget=-1 96 | ! write(sparse%unlog,'(a)')' Warning: a sparse matrix has only 2 dimensions!' 97 | end select 98 | 99 | end function 100 | 101 | !GET MEMORY 102 | module function getmem_gen(sparse) result(getmem) 103 | class(gen_sparse),intent(in)::sparse 104 | integer(kind=int64)::getmem 105 | 106 | getmem=sizeof(sparse%unlog)+sizeof(sparse%dim1)+sizeof(sparse%dim2)+sizeof(sparse%namemat)& 107 | +sizeof(sparse%lsymmetric)+sizeof(sparse%lupperstorage) 108 | if(allocated(sparse%perm))getmem=getmem+sizeof(sparse%perm) 109 | if(allocated(sparse%perm64))getmem=getmem+sizeof(sparse%perm64) 110 | 111 | end function 112 | 113 | !** GET PERMUTATION VECTOR 114 | module subroutine getpermutation32(sparse,array) 115 | class(gen_sparse),intent(in)::sparse 116 | integer(kind=int32),intent(out),allocatable::array(:) 117 | 118 | if(allocated(sparse%perm))then 119 | allocate(array, source = sparse%perm) 120 | else 121 | write(sparse%unlog,'(a)')' ERROR: The permutation array is not allocated.' 122 | error stop 123 | endif 124 | 125 | end subroutine 126 | 127 | module subroutine getpermutation64(sparse,array) 128 | class(gen_sparse),intent(in)::sparse 129 | integer(kind=int64),intent(out),allocatable::array(:) 130 | 131 | if(allocated(sparse%perm64))then 132 | allocate(array, source = sparse%perm64) 133 | else 134 | write(sparse%unlog,'(a)')' ERROR: The permutation array (int64) is not allocated.' 135 | error stop 136 | endif 137 | 138 | end subroutine 139 | 140 | !**GET OUTPUT UNIT 141 | pure module function getoutputunit(sparse) result(val) 142 | class(gen_sparse),intent(in)::sparse 143 | integer(kind=int32)::val 144 | 145 | val = sparse%unlog 146 | end function 147 | 148 | !INITIATE GEN SPARSE 149 | module subroutine init_gen(sparse,namemat,dim1,dim2) 150 | class(gen_sparse),intent(inout)::sparse 151 | integer(kind=int32),intent(in)::dim1,dim2 152 | character(len=*),intent(in)::namemat 153 | 154 | sparse%namemat=namemat 155 | 156 | sparse%dim1=dim1 157 | sparse%dim2=dim2 158 | 159 | sparse%lsorted=.false. 160 | sparse%lsymmetric=.false. 161 | sparse%lupperstorage=.false. 162 | 163 | end subroutine 164 | 165 | !**PRINT 166 | module subroutine print_dim_gen(sparse) 167 | class(gen_sparse),intent(in)::sparse 168 | 169 | write(sparse%unlog,'(/" Type of the matrix : ",a)')trim(sparse%namemat) 170 | write(sparse%unlog,'( " Output unit : ",i0)')sparse%unlog 171 | write(sparse%unlog,'( " Dimension of the matrix : ",i0," x ",i0)')sparse%dim1,sparse%dim2 172 | write(sparse%unlog,'( " Number of non-zero elements : ",i0)')sparse%nonzero() 173 | write(sparse%unlog,'( " Sorted : ",l1)')sparse%issorted() 174 | write(sparse%unlog,'( " Symmetric : ",l1)')sparse%lsymmetric 175 | write(sparse%unlog,'( " Upper storage : ",l1)')sparse%lupperstorage 176 | write(sparse%unlog,'( " Permutation array provided : ",l1)')(allocated(sparse%perm).or.allocated(sparse%perm64)) 177 | 178 | select type(sparse) 179 | type is(coosparse) 180 | write(sparse%unlog,'( " Memory (B) : ",i0)')sparse%getmem() 181 | write(sparse%unlog,'( " Size of the array : ",i0)')sparse%nel 182 | type is(crssparse) 183 | write(sparse%unlog,'( " Memory (B) : ",i0)')sparse%getmem() 184 | write(sparse%unlog,'( " Original status : ",l1)')sparse%loriginal 185 | type is(crssparse64) 186 | write(sparse%unlog,'( " Memory (B) : ",i0)')sparse%getmem() 187 | write(sparse%unlog,'( " Original status : ",l1)')sparse%loriginal 188 | class default 189 | write(sparse%unlog,'(a)')"Undefined sparse matrix" 190 | end select 191 | write(sparse%unlog,'(a)')' ' 192 | 193 | end subroutine 194 | 195 | module subroutine printtofile_gen(sparse,namefile,lint) 196 | class(gen_sparse),intent(in)::sparse 197 | character(len=*),intent(in)::namefile 198 | logical,intent(in),optional::lint 199 | 200 | integer(kind=int32)::un 201 | logical::linternal 202 | 203 | linternal=.true. 204 | if(present(lint))linternal=lint 205 | 206 | open(newunit=un,file=namefile,status='replace',action='write') 207 | call sparse%print(lint=linternal,output=un) 208 | close(un) 209 | 210 | end subroutine 211 | 212 | module subroutine printsquaretofile_gen(sparse,namefile) 213 | class(gen_sparse),intent(inout)::sparse 214 | character(len=*),intent(in)::namefile 215 | 216 | integer(kind=int32)::un 217 | 218 | open(newunit=un,file=namefile,status='replace',action='write') 219 | call sparse%printsquare(output=un) 220 | close(un) 221 | 222 | end subroutine 223 | 224 | !**SET OUTPUT UNIT 225 | pure module subroutine setoutputunit(sparse,unlog) 226 | class(gen_sparse),intent(inout)::sparse 227 | integer(kind=int32),intent(in)::unlog 228 | 229 | sparse%unlog=unlog 230 | 231 | end subroutine 232 | 233 | !** SET PERMUTATION VECTOR 234 | module subroutine setpermutation32(sparse,array) 235 | class(gen_sparse),intent(inout)::sparse 236 | integer(kind=int32)::array(:) 237 | 238 | if(size(array).ne.sparse%getdim(1))then 239 | write(sparse%unlog,'(a)')' ERROR: The permutation array has a wrong size.' 240 | error stop 241 | endif 242 | 243 | !Probably pointer would be better??? 244 | if(.not.allocated(sparse%perm))allocate(sparse%perm(sparse%getdim(1))) 245 | sparse%perm=array 246 | 247 | end subroutine 248 | 249 | module subroutine setpermutation64(sparse,array) 250 | class(gen_sparse),intent(inout)::sparse 251 | integer(kind=int64)::array(:) 252 | 253 | if(size(array).ne.sparse%getdim(1))then 254 | write(sparse%unlog,'(a)')' ERROR: The permutation array (int64) has a wrong size.' 255 | error stop 256 | endif 257 | 258 | !Probably pointer would be better??? 259 | if(.not.allocated(sparse%perm64))allocate(sparse%perm64(sparse%getdim(1))) 260 | sparse%perm64=array 261 | 262 | end subroutine 263 | 264 | ! SET THE STATUS SORTED 265 | pure module subroutine setsorted(sparse,ll) 266 | class(gen_sparse),intent(inout)::sparse 267 | logical,intent(in)::ll 268 | 269 | sparse%lsorted=ll 270 | 271 | end subroutine 272 | 273 | ! SET THE STATUS SYMMETRIC 274 | module subroutine setsymmetric(sparse,ll) 275 | class(gen_sparse),intent(inout)::sparse 276 | logical,intent(in),optional::ll 277 | 278 | logical::lll 279 | 280 | if(.not.sparse%issquare().and..not.present(ll))then 281 | write(sparse%unlog,'(a)')' ERROR: the sparse matrix is not square and cannot be set to symmetric!' 282 | error stop 283 | elseif(.not.sparse%issquare().and.present(ll))then 284 | if(ll)then 285 | write(sparse%unlog,'(a)')' ERROR: the sparse matrix is not square and cannot be set to symmetric as requested!' 286 | error stop 287 | endif 288 | endif 289 | 290 | lll=.true. 291 | if(present(ll))lll=ll 292 | 293 | sparse%lsymmetric=lll 294 | 295 | end subroutine 296 | 297 | 298 | !**OTHER 299 | pure module function issorted(sparse) result(ll) 300 | class(gen_sparse),intent(in)::sparse 301 | logical::ll 302 | 303 | ll=sparse%lsorted 304 | 305 | end function 306 | 307 | pure module function issquare(sparse) result(ll) 308 | class(gen_sparse),intent(in)::sparse 309 | logical::ll 310 | 311 | ll=.true. 312 | if(sparse%dim1.ne.sparse%dim2)ll=.false. 313 | 314 | end function 315 | 316 | !CHECKS 317 | pure module function validvalue_gen(sparse,row,col) result(lvalid) 318 | class(gen_sparse),intent(in)::sparse 319 | integer(kind=int32),intent(in)::row,col 320 | logical::lvalid 321 | 322 | lvalid=.true. 323 | if((row.lt.1.or.row.gt.sparse%dim1).or.(col.lt.1.or.col.gt.sparse%dim2))lvalid=.false. 324 | 325 | end function 326 | 327 | pure module function validnonzero_gen(sparse,val) result(lvalid) 328 | class(gen_sparse),intent(in)::sparse 329 | real(kind=wp),intent(in)::val 330 | logical::lvalid 331 | 332 | lvalid=.true. 333 | if((abs(val) Module containing functions for hashing 2 | 3 | module modsparse_hash 4 | use iso_fortran_env,only:int32,int64,real64 5 | implicit none 6 | private 7 | public::hashf,roundinguppower2 8 | 9 | interface hashf 10 | module procedure hashf_vect,hashf_array 11 | module procedure hashf_array_getval 12 | end interface 13 | 14 | integer(kind=int64), parameter :: bparam = 11_int64 !default value for 2nd coordinate 15 | integer(kind=int64), parameter :: cparam = 305419896_int64 !default value for 3rd coordinate 16 | contains 17 | !Inspired by lookup3.c from Bob Jenkins (http://burtleburtle.net/bob/hash/index.html#lookup) 18 | !Converted in Fortran by Francois Guillaume - 2011 19 | !Simplifications made by Jeremie Vandenplas - 2018 20 | 21 | !PUBLIC 22 | !> @brief Function hashing an integer to return a hash address 23 | function hashf_vect(row,mat,dim2,filled,getval) result(address) 24 | !address: address (row) of mat 25 | !mat of size dim2 26 | !filled: number of elements 27 | !getval .eq. .true. : search for a value and returns 0 if absent 28 | !getval .eq. .false.: add a value if row,col was not present before 29 | integer(kind=int64)::address 30 | integer(kind=int32),intent(in)::row 31 | integer(kind=int32),intent(inout)::mat(:) 32 | integer(kind=int64),intent(in)::dim2 33 | integer(kind=int64),intent(inout)::filled 34 | logical,intent(in)::getval 35 | 36 | integer(kind=int32),parameter::maxiter=5000 37 | 38 | integer(kind=int64)::a,b,c 39 | integer(kind=int32)::i 40 | logical::indzero,indequal 41 | 42 | a = int(row,kind(a)) !conversion of 1st coordinate 43 | b = bparam !conversion of 2nd coordinate 44 | c = cparam !default value for 3rd coordinate 45 | 46 | !Cycle until a free entry is found 47 | do i = 1, maxiter 48 | !Hashing 49 | call mix(a,b,c) 50 | !Computation of the address 51 | address = iand(c, dim2-1) + 1 52 | !Check if the address is correct 53 | indzero = .false. 54 | indequal = .false. 55 | if(mat(address).eq.row)indequal = .true. 56 | if(mat(address).eq.0)indzero = .true. 57 | if(indzero.or.indequal)then 58 | if(.not.getval.and.indzero)then 59 | mat(address) = row 60 | filled = filled + 1 61 | return 62 | endif 63 | if(getval.and.indzero)then 64 | address = 0 65 | endif 66 | return 67 | endif 68 | enddo 69 | 70 | address = -1 71 | write(*,'(a)')' Warning: the maximum number of searches was reached!' 72 | 73 | end function 74 | 75 | !> @brief Function hashing a row and a column to return a hash address 76 | function hashf_array(row,col,mat,dim2,filled,getval) result(address) 77 | !address: address (column) of mat 78 | !mat of size dim1 (=2) x dim2 79 | !filled: number of elements 80 | !getval .eq. .true. : search for a value and returns 0 if absent 81 | !getval .eq. .false.: add a value if row,col was not present before 82 | integer(kind=int64)::address 83 | integer(kind=int32),intent(in)::row,col 84 | integer(kind=int32),intent(inout)::mat(:,:) 85 | integer(kind=int64),intent(in)::dim2 86 | integer(kind=int64),intent(inout)::filled 87 | logical,intent(in)::getval 88 | 89 | integer(kind=int32),parameter::maxiter=5000 90 | 91 | integer(kind=int64)::a,b,c 92 | integer(kind=int32)::i 93 | logical::indzero,indequal 94 | 95 | a = int(row,kind(a)) !conversion of 1st coordinate 96 | b = int(col,kind(b)) !conversion of 2nd coordinate 97 | c = cparam !default value for 3rd coordinate 98 | 99 | !Cycle until a free entry is found 100 | do i = 1, maxiter 101 | !Hashing 102 | call mix(a,b,c) 103 | !Computation of the address 104 | address = iand(c,dim2-1) + 1 105 | !Check if the address is correct 106 | indzero = .false. 107 | indequal = .false. 108 | if(mat(1,address).eq.row.and.mat(2,address).eq.col)indequal = .true. 109 | if(mat(1,address).eq.0.or.mat(2,address).eq.0)indzero = .true. 110 | if(indzero.or.indequal)then 111 | if(.not.getval.and.indzero)then 112 | mat(1,address) = row 113 | mat(2,address) = col 114 | filled = filled + 1 115 | return 116 | endif 117 | if(getval.and.indzero)then 118 | address = 0 119 | endif 120 | return 121 | endif 122 | enddo 123 | 124 | address = -1 125 | write(*,'(a)')' Warning: the maximum number of searches was reached!' 126 | 127 | end function 128 | 129 | pure function hashf_array_getval(row,col,mat,dim2) result(address) 130 | !address: address (column) of mat 131 | !mat of size dim1 (=2) x dim2 132 | !search for a value and returns 0 if absent 133 | integer(kind=int64)::address 134 | integer(kind=int32),intent(in)::row,col 135 | integer(kind=int32),intent(in)::mat(:,:) 136 | integer(kind=int64),intent(in)::dim2 137 | 138 | integer(kind=int32),parameter::maxiter=5000 139 | 140 | integer(kind=int64)::a,b,c 141 | integer(kind=int32)::i 142 | logical::indzero,indequal 143 | 144 | a = int(row,kind(a)) !conversion of 1st coordinate 145 | b = int(col,kind(b)) !conversion of 2nd coordinate 146 | c = cparam !default value for 3rd coordinate 147 | 148 | !Cycle until a free entry is found 149 | do i = 1, maxiter 150 | !Hashing 151 | call mix(a,b,c) 152 | !Computation of the address 153 | address = iand(c,dim2-1) + 1 154 | !Check if the address is correct 155 | indzero = .false. 156 | indequal = .false. 157 | if(mat(1,address).eq.row.and.mat(2,address).eq.col)indequal = .true. 158 | if(mat(1,address).eq.0.or.mat(2,address).eq.0)indzero = .true. 159 | if(indzero.or.indequal)then 160 | if(indzero)address = 0 161 | return 162 | endif 163 | enddo 164 | 165 | address = -1 166 | 167 | end function 168 | 169 | !> @brief Function returning the next power of 2 of a number 170 | pure function roundinguppower2(x) result(next) 171 | integer(kind=int64),intent(in)::x 172 | integer(kind=int64)::next 173 | 174 | real(real64), parameter :: log2 = log(2._real64) 175 | 176 | next = 2_int64 ** int((ceiling( log(real(x, real64)) / log2) ), int64) 177 | 178 | end function 179 | 180 | !PRIVATE 181 | pure function rot(i,j) result(rota) 182 | integer(kind=int64), intent(in) :: i,j 183 | integer(kind=int64)::rota 184 | 185 | rota=ior(ishft(i,j),ishft(i,-(32_int64-j))) 186 | 187 | end function 188 | 189 | pure subroutine mix(a,b,c) 190 | integer(kind=int64),intent(inout)::a,b,c 191 | 192 | a=a-c; a=ieor(a,rot(c,4_int64)); c=c+b 193 | b=b-a; b=ieor(b,rot(a,6_int64)); a=a+c 194 | c=c-b; c=ieor(c,rot(b,8_int64)); b=b+a 195 | a=a-c; a=ieor(a,rot(c,16_int64)); c=c+b 196 | b=b-a; b=ieor(b,rot(a,19_int64)); a=a+c 197 | c=c-b; c=ieor(c,rot(b,4_int64)); b=b+a 198 | 199 | end subroutine 200 | 201 | end module 202 | -------------------------------------------------------------------------------- /src/modsparse_ll.f90: -------------------------------------------------------------------------------- 1 | submodule (modsparse) modsparse_ll 2 | !$ use omp_lib 3 | implicit none 4 | 5 | contains 6 | 7 | !**CONSTRUCTOR 8 | module subroutine constructor_sub_ll(sparse,m,n,lupper,unlog) 9 | class(llsparse),intent(out)::sparse 10 | integer(kind=int32),intent(in)::m 11 | integer(kind=int32),intent(in),optional::n,unlog 12 | logical,intent(in),optional::lupper 13 | 14 | call sparse%initialize('LINKED LIST',m,m) 15 | 16 | if(present(n))sparse%dim2=n 17 | if(present(lupper))sparse%lupperstorage=lupper 18 | if(present(unlog))sparse%unlog=unlog 19 | 20 | sparse%lsymmetric=.false. 21 | 22 | allocate(sparse%heads(sparse%dim1)) 23 | 24 | end subroutine 25 | 26 | !**DESTROY 27 | module elemental subroutine destroy_scal_ptrnode(pnode) 28 | type(ptrnode), intent(inout)::pnode 29 | 30 | type(ptrnode)::cursor 31 | 32 | do while(associated(pnode%p)) 33 | cursor=pnode 34 | pnode=pnode%p%next 35 | deallocate(cursor%p) 36 | nullify(cursor%p) 37 | enddo 38 | 39 | end subroutine 40 | 41 | module elemental subroutine destroy_ll(sparse) 42 | class(llsparse),intent(inout)::sparse 43 | integer(kind=int32)::i 44 | 45 | call sparse%destroy_gen_gen() 46 | 47 | if(allocated(sparse%heads))then 48 | do i=1,size(sparse%heads) 49 | call destroy_scal_ptrnode(sparse%heads(i)) 50 | enddo 51 | deallocate(sparse%heads) 52 | endif 53 | 54 | end subroutine 55 | 56 | !**DIAGONAL ELEMENTS 57 | 58 | !EQUALITIES 59 | module subroutine equal_node(nodeout,nodein) 60 | class(node),intent(out)::nodeout 61 | class(node),intent(in)::nodein 62 | 63 | nodeout%col=nodein%col 64 | nodeout%val=nodein%val 65 | 66 | end subroutine 67 | 68 | !**ADD ELEMENTS 69 | module subroutine addtohead_ptrnode(pnode,col,val) 70 | type(ptrnode),intent(inout),pointer::pnode 71 | integer(kind=int32),intent(in)::col 72 | real(kind=wp),intent(in)::val 73 | 74 | type(ptrnode)::cursor 75 | 76 | allocate(cursor%p) 77 | cursor%p%next=pnode 78 | cursor%p%col=col 79 | cursor%p%val=val 80 | pnode=cursor 81 | 82 | end subroutine 83 | 84 | module subroutine addtohead_ll(sparse,row,col,val) 85 | class(llsparse),intent(inout),target::sparse 86 | integer(kind=int32),intent(in)::row,col 87 | real(kind=wp),intent(in)::val 88 | 89 | type(ptrnode)::cursor 90 | 91 | if(.not.validvalue_gen(sparse,row,col))return 92 | if(.not.validnonzero_gen(sparse,val))return 93 | if(sparse%lupperstorage.and..not.uppervalue_gen(row,col))return 94 | 95 | allocate(cursor%p) 96 | cursor%p%next=sparse%heads(row) 97 | cursor%p%col=col 98 | cursor%p%val=val 99 | sparse%heads(row)=cursor 100 | 101 | end subroutine 102 | 103 | module subroutine addinorder_ll(sparse,row,col,val) 104 | class(llsparse),intent(inout),target::sparse 105 | integer(kind=int32),intent(in)::row,col 106 | real(kind=wp),intent(in)::val 107 | 108 | type(ptrnode),pointer::cursor 109 | 110 | if(.not.validvalue_gen(sparse,row,col))return 111 | if(.not.validnonzero_gen(sparse,val))return 112 | if(sparse%lupperstorage.and..not.uppervalue_gen(row,col))return 113 | 114 | cursor=>sparse%heads(row) 115 | do while(associated(cursor%p)) 116 | if(cursor%p%col.ge.col)then 117 | if(.not.col.ge.cursor%p%col)then 118 | call addtohead_ptrnode(cursor,col,val) 119 | else 120 | cursor%p%val=cursor%p%val+val 121 | endif 122 | return 123 | endif 124 | cursor=>cursor%p%next 125 | enddo 126 | allocate(cursor%p) 127 | cursor%p%col=col 128 | cursor%p%val=val 129 | 130 | end subroutine 131 | 132 | module subroutine addtotail_ll(sparse,row,col,val) 133 | class(llsparse),intent(inout),target::sparse 134 | integer(kind=int32),intent(in)::row,col 135 | real(kind=wp),intent(in)::val 136 | 137 | type(ptrnode),pointer::cursor 138 | 139 | if(.not.validvalue_gen(sparse,row,col))return 140 | if(.not.validnonzero_gen(sparse,val))return 141 | if(sparse%lupperstorage.and..not.uppervalue_gen(row,col))return 142 | 143 | cursor=>sparse%heads(row) 144 | do while(associated(cursor%p)) 145 | cursor=>cursor%p%next 146 | enddo 147 | allocate(cursor%p) 148 | cursor%p%col=col 149 | cursor%p%val=val 150 | 151 | end subroutine 152 | 153 | !**GET ELEMENTS 154 | pure module function get_ll(sparse,row,col) result(val) 155 | class(llsparse),intent(in)::sparse 156 | integer(kind=int32),intent(in)::row,col 157 | real(kind=wp)::val 158 | 159 | integer(kind=int32)::trow,tcol 160 | type(ptrnode),pointer::cursor 161 | type(ptrnode),target, allocatable::replacecursor 162 | 163 | val=0.0_wp 164 | 165 | trow=row 166 | tcol=col 167 | if(sparse%lupperstorage.and.row.gt.col)then 168 | !swap row-col 169 | trow=col 170 | tcol=row 171 | endif 172 | 173 | !cursor=>sparse%heads(trow) 174 | allocate(replacecursor, source=sparse%heads(trow)) 175 | cursor=>replacecursor 176 | 177 | do while(associated(cursor%p)) 178 | if(cursor%p%col.eq.tcol)then 179 | val=cursor%p%val 180 | exit 181 | endif 182 | cursor=>cursor%p%next 183 | enddo 184 | 185 | end function 186 | 187 | !**EXTERNAL 188 | 189 | !**LOAD 190 | 191 | !**MULTIPLICATIONS 192 | module subroutine multgenv_ll(sparse,alpha,trans,x,val,y) 193 | !Computes y=val*y+alpha*sparse(tranposition)*x 194 | class(llsparse),intent(in)::sparse 195 | real(kind=wp),intent(in)::val,alpha 196 | real(kind=wp),intent(in)::x(:) 197 | real(kind=wp),intent(out)::y(:) 198 | character(len=1),intent(in)::trans 199 | 200 | y=0._wp 201 | write(sparse%unlog,'(a)')' ERROR: Multiplication mult not implemented for llsparse' 202 | error stop 203 | 204 | end subroutine 205 | 206 | module subroutine multgenm_ll(sparse,alpha,trans,x,val,y) 207 | !Computes y=val*y+alpha*sparse(tranposition)*x 208 | class(llsparse),intent(in)::sparse 209 | real(kind=wp),intent(in)::val,alpha 210 | real(kind=wp),intent(in)::x(:,:) 211 | real(kind=wp),intent(out)::y(:,:) 212 | character(len=1),intent(in)::trans 213 | 214 | y=0._wp 215 | write(sparse%unlog,'(a)')' ERROR: Multiplication mult not implemented for llsparse' 216 | error stop 217 | 218 | end subroutine 219 | 220 | !**NUMBER OF ELEMENTS 221 | module function totalnumberofelements_ptrnode(pnode) result(nel) 222 | class(ptrnode),intent(in),target::pnode 223 | integer(kind=int64)::nel 224 | 225 | type(ptrnode),pointer::cursor 226 | 227 | nel=0 228 | cursor=>pnode 229 | do while(associated(cursor%p)) 230 | nel=nel+1 231 | cursor=>cursor%p%next 232 | enddo 233 | 234 | end function 235 | 236 | module function totalnumberofelements_ll(sparse) result(nel) 237 | class(llsparse),intent(in)::sparse 238 | integer(kind=int64)::nel 239 | 240 | integer(kind=int32)::i 241 | 242 | nel=0 243 | do i=1,sparse%dim1 244 | nel=nel+sparse%heads(i)%size() 245 | enddo 246 | 247 | end function 248 | 249 | !**SAVE 250 | 251 | !**SCALE ALL ENTRIES 252 | module subroutine scale_ll(sparse,val) 253 | class(llsparse),intent(inout)::sparse 254 | real(kind=wp),intent(in)::val 255 | 256 | write(sparse%unlog,'(a)')' ERROR: scale not implemented for llsparse' 257 | error stop 258 | 259 | end subroutine 260 | 261 | !**SET ELEMENTS 262 | 263 | !**SOLVE 264 | 265 | !**SORT ARRAY 266 | 267 | !**SUBMATRIX 268 | 269 | !**PRINT 270 | module subroutine print_ll(sparse,lint,output) 271 | class(llsparse),intent(in)::sparse 272 | integer(kind=int32),intent(in),optional::output 273 | logical,intent(in),optional::lint 274 | 275 | integer(kind=int32)::i,un 276 | character(len=20)::frm='(2(i0,1x),g0)' 277 | logical::linternal 278 | type(ptrnode),pointer::cursor 279 | type(ptrnode),target::replacecursor 280 | 281 | linternal=.true. 282 | if(present(lint))linternal=lint 283 | 284 | un=sparse%unlog 285 | if(present(output))un=output 286 | 287 | do i=1,sparse%dim1 288 | !cursor=>sparse%heads(i) 289 | replacecursor=sparse%heads(i) 290 | cursor=>replacecursor 291 | do while(associated(cursor%p)) 292 | write(un,frm)i,cursor%p%col,cursor%p%val 293 | if(.not.linternal.and.sparse%lupperstorage.and.sparse%lsymmetric.and.cursor%p%col.ne.i)then 294 | write(un,frm)cursor%p%col,i,cursor%p%val 295 | endif 296 | cursor=>cursor%p%next 297 | enddo 298 | enddo 299 | 300 | end subroutine 301 | 302 | module subroutine print_idx_ll(sparse,lidx,lint,output) 303 | class(llsparse),intent(in)::sparse 304 | logical,intent(in)::lidx(:) 305 | integer(kind=int32),intent(in),optional::output 306 | logical,intent(in),optional::lint 307 | 308 | integer(kind=int32)::i,un 309 | character(len=20)::frm='(2(i0,1x),g0)' 310 | logical::linternal 311 | type(ptrnode),pointer::cursor 312 | type(ptrnode),target::replacecursor 313 | 314 | linternal=.true. 315 | if(present(lint))linternal=lint 316 | 317 | un=sparse%unlog 318 | if(present(output))un=output 319 | 320 | do i=1,sparse%dim1 321 | if(.not.lidx(i))cycle 322 | !cursor=>sparse%heads(i) 323 | replacecursor=sparse%heads(i) 324 | cursor=>replacecursor 325 | do while(associated(cursor%p)) 326 | if(.not.lidx(cursor%p%col))then 327 | write(un,frm)i,cursor%p%col,cursor%p%val 328 | if(.not.linternal.and.sparse%lupperstorage.and.sparse%lsymmetric.and.cursor%p%col.ne.i)then 329 | write(un,frm)cursor%p%col,i,cursor%p%val 330 | endif 331 | endif 332 | cursor=>cursor%p%next 333 | enddo 334 | enddo 335 | 336 | end subroutine 337 | 338 | module subroutine printsquare_ll(sparse,output) 339 | class(llsparse),intent(inout)::sparse 340 | integer(kind=int32),intent(in),optional::output 341 | 342 | integer(kind=int32)::un 343 | real(kind=wp),allocatable::tmp(:) 344 | 345 | un=sparse%unlog 346 | if(present(output))un=output 347 | 348 | write(un,'(a)')' Warning: this subroutine is not implemented yet!' 349 | 350 | allocate(tmp(sparse%dim2)) 351 | 352 | end subroutine 353 | 354 | 355 | end submodule 356 | -------------------------------------------------------------------------------- /src/modsparse_metisgraph.f90: -------------------------------------------------------------------------------- 1 | submodule (modsparse) modsparse_metisgraph 2 | !$ use omp_lib 3 | implicit none 4 | 5 | contains 6 | !**CONSTRUCTOR 7 | module subroutine constructor_sub_metisgraph(metis,n,m,unlog) 8 | class(metisgraph),intent(out)::metis 9 | integer(kind=int32),intent(in)::n,m 10 | integer(kind=int32),intent(in),optional::unlog 11 | 12 | metis%unlog=6 13 | if(present(unlog))metis%unlog=unlog 14 | 15 | metis%nvertices=n 16 | metis%medges=m 17 | allocate(metis%xadj(metis%nvertices+1),metis%adjncy(2*metis%medges)) 18 | metis%xadj=0 19 | metis%adjncy=0 20 | metis%vwgt=c_null_ptr 21 | metis%adjwgt=c_null_ptr 22 | 23 | end subroutine 24 | 25 | 26 | !** GET MEMORY 27 | pure module function getmem_metisgraph(metis) result(getmem) 28 | class(metisgraph),intent(in)::metis 29 | integer(kind=int64)::getmem 30 | 31 | getmem=sizeof(metis%unlog)+sizeof(metis%nvertices)+sizeof(metis%medges) 32 | if(allocated(metis%xadj))getmem=getmem+sizeof(metis%xadj) 33 | if(allocated(metis%adjncy))getmem=getmem+sizeof(metis%adjncy) 34 | 35 | !what to do with the pointers??? 36 | 37 | end function 38 | 39 | 40 | end submodule 41 | -------------------------------------------------------------------------------- /src/modsparse_mkl.f90: -------------------------------------------------------------------------------- 1 | include 'mkl_pardiso.f90' 2 | module modsparse_mkl 3 | use mkl_pardiso 4 | include 'mkl_blas.fi' 5 | include 'mkl_trans.fi' 6 | include 'mkl_spblas.fi' 7 | include 'mkl_lapack.fi' 8 | include 'mkl_dss.fi' 9 | include 'mkl_rci.fi' 10 | include 'mkl_vml.fi' 11 | include 'mkl_service.fi' 12 | include 'mkl_solvers_ee.fi' 13 | end module 14 | -------------------------------------------------------------------------------- /src/modvariablepardiso.f90: -------------------------------------------------------------------------------- 1 | !> Module containing a derived type for MKL Pardiso variables 2 | 3 | !> @todo Not happy with the phase variable and how it is handled in modsparse 4 | 5 | module modvariablepardiso 6 | use modsparse_mkl, only: mkl_pardiso_handle 7 | #if (_DP==0) 8 | use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real32 9 | #else 10 | use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real64 11 | #endif 12 | !$ use omp_lib 13 | implicit none 14 | private 15 | public::checkpardiso, checkpardiso_64 16 | public::pardiso_variable, pardiso_variable_64 17 | 18 | ! type::pardiso_pt 19 | ! integer(kind=8)::pt 20 | ! end type 21 | 22 | type::pardiso_variable 23 | !Default Pardiso variables 24 | integer(kind=int32)::idum(1) 25 | real(kind=wp)::ddum(1) 26 | integer(kind=int32)::maxfct 27 | integer(kind=int32)::mnum 28 | integer(kind=int32)::mtype 29 | integer(kind=int32)::msglvl 30 | integer(kind=int32)::phase 31 | integer(kind=int32)::solver 32 | integer(kind=int32),allocatable::iparm(:) 33 | type(mkl_pardiso_handle),allocatable::pt(:) 34 | contains 35 | final::reset_pardiso_variable 36 | end type 37 | 38 | type::pardiso_variable_64 39 | !Default Pardiso variables 40 | integer(kind=int64)::idum(1) 41 | real(kind=wp)::ddum(1) 42 | integer(kind=int64)::maxfct 43 | integer(kind=int64)::mnum 44 | integer(kind=int64)::mtype 45 | integer(kind=int64)::msglvl 46 | integer(kind=int64)::phase 47 | integer(kind=int64)::solver 48 | integer(kind=int64),allocatable::iparm(:) 49 | type(mkl_pardiso_handle),allocatable::pt(:) 50 | contains 51 | final::reset_pardiso_variable_64 52 | end type 53 | 54 | interface pardiso_variable 55 | module procedure constructor_pardiso_variable 56 | end interface 57 | 58 | interface pardiso_variable_64 59 | module procedure constructor_pardiso_variable_64 60 | end interface 61 | 62 | contains 63 | 64 | !**CONSTRUCTOR 65 | pure function constructor_pardiso_variable(maxfct,mnum,mtype,solver,msglvl) result(this) 66 | type(pardiso_variable)::this 67 | integer(kind=int32),intent(in),optional::maxfct 68 | integer(kind=int32),intent(in),optional::mnum 69 | integer(kind=int32),intent(in),optional::mtype 70 | integer(kind=int32),intent(in),optional::solver 71 | integer(kind=int32),intent(in),optional::msglvl 72 | 73 | integer(kind=int32)::i 74 | 75 | this%phase=-9 76 | 77 | this%maxfct=1 78 | if(present(maxfct))this%maxfct=maxfct 79 | 80 | this%mnum=1 81 | if(present(mnum))this%mnum=mnum 82 | 83 | this%mtype=-2 84 | if(present(mtype))this%mtype=mtype 85 | 86 | this%solver=0 87 | if(present(solver))this%solver=solver 88 | 89 | this%msglvl=1 90 | if(present(msglvl))this%msglvl=msglvl 91 | 92 | allocate(this%iparm(64)) 93 | this%iparm=0 94 | 95 | allocate(this%pt(64)) 96 | do i=1,64 97 | this%pt(i)%dummy=0 98 | enddo 99 | 100 | end function 101 | 102 | pure function constructor_pardiso_variable_64(maxfct,mnum,mtype,solver,msglvl) result(this) 103 | type(pardiso_variable_64)::this 104 | integer(kind=int64),intent(in),optional::maxfct 105 | integer(kind=int64),intent(in),optional::mnum 106 | integer(kind=int64),intent(in),optional::mtype 107 | integer(kind=int64),intent(in),optional::solver 108 | integer(kind=int64),intent(in),optional::msglvl 109 | 110 | integer(kind=int64)::i 111 | 112 | this%phase=-9 113 | 114 | this%maxfct=1 115 | if(present(maxfct))this%maxfct=maxfct 116 | 117 | this%mnum=1 118 | if(present(mnum))this%mnum=mnum 119 | 120 | this%mtype=-2 121 | if(present(mtype))this%mtype=mtype 122 | 123 | this%solver=0 124 | if(present(solver))this%solver=solver 125 | 126 | this%msglvl=1 127 | if(present(msglvl))this%msglvl=msglvl 128 | 129 | allocate(this%iparm(64)) 130 | this%iparm=0 131 | 132 | allocate(this%pt(64)) 133 | do i=1,64 134 | this%pt(i)%dummy=0 135 | enddo 136 | 137 | end function 138 | 139 | !**OTHER 140 | subroutine checkpardiso(phase,error,un) 141 | integer(kind=int32),intent(in)::phase,error 142 | integer(kind=int32),intent(in),optional::un 143 | 144 | integer(kind=int32)::unlog 145 | 146 | unlog=output_unit 147 | if(present(un))unlog=un 148 | 149 | if(error.ne.0)then 150 | write(unlog,'(2(a,i0))')' The following error for phase ',phase,' was detected: ',error 151 | error stop 152 | endif 153 | 154 | end subroutine 155 | 156 | subroutine checkpardiso_64(phase,error,un) 157 | integer(kind=int64),intent(in)::phase,error 158 | integer(kind=int32),intent(in),optional::un 159 | 160 | integer(kind=int32)::unlog 161 | 162 | unlog=output_unit 163 | if(present(un))unlog=un 164 | 165 | if(error.ne.0)then 166 | write(unlog,'(2(a,i0))')' The following error for phase ',phase,' was detected: ',error 167 | error stop 168 | endif 169 | 170 | end subroutine 171 | 172 | !FINAL 173 | subroutine reset_pardiso_variable(this) 174 | type(pardiso_variable),intent(inout)::this 175 | 176 | this%maxfct=1 177 | this%mnum=1 178 | this%mtype=-2 179 | this%solver=0 180 | this%idum=0 181 | this%ddum=0._wp 182 | this%msglvl=1 183 | this%phase=-9 184 | if(allocated(this%iparm))deallocate(this%iparm) 185 | if(allocated(this%pt))deallocate(this%pt) 186 | 187 | end subroutine 188 | 189 | subroutine reset_pardiso_variable_64(this) 190 | type(pardiso_variable_64),intent(inout)::this 191 | 192 | this%maxfct=1 193 | this%mnum=1 194 | this%mtype=-2 195 | this%solver=0 196 | this%idum=0 197 | this%ddum=0._wp 198 | this%msglvl=1 199 | this%phase=-9 200 | if(allocated(this%iparm))deallocate(this%iparm) 201 | if(allocated(this%pt))deallocate(this%pt) 202 | 203 | end subroutine 204 | 205 | end module 206 | -------------------------------------------------------------------------------- /src/sgtrsm.f: -------------------------------------------------------------------------------- 1 | C 2 | C =========== DOCUMENTATION =========== 3 | C 4 | C Online html documentation available at 5 | C http://www.netlib.org/lapack/explore-html/ 6 | C 7 | C Definition: 8 | C =========== 9 | C 10 | C SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 11 | C 12 | C .. Scalar Arguments .. 13 | C REAL ALPHA 14 | C INTEGER LDA,LDB,M,N 15 | C CHARACTER DIAG,SIDE,TRANSA,UPLO 16 | C .. 17 | C .. Array Arguments .. 18 | C REAL A(LDA,*),B(LDB,*) 19 | C .. 20 | C 21 | C 22 | C> \par Purpose: 23 | C ============= 24 | C> 25 | C> \verbatim 26 | C> 27 | C> STRSM solves one of the matrix equations 28 | C> 29 | C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, 30 | C> 31 | C> where alpha is a scalar, X and B are m by n matrices, A is a unit, 32 | Cor 33 | C> non-unit, upper or lower triangular matrix and op( A ) is one 34 | Cof 35 | C> 36 | C> op( A ) = A or op( A ) = A**T. 37 | C> 38 | C> The matrix X is overwritten on B. 39 | C> \endverbatim 40 | C 41 | C Arguments: 42 | C ========== 43 | C 44 | C> \param[in] SIDE 45 | C> \verbatim 46 | C> SIDE is CHARACTER*1 47 | C> On entry, SIDE specifies whether op( A ) appears on the 48 | Cleft 49 | C> or right of X as follows: 50 | C> 51 | C> SIDE = 'L' or 'l' op( A )*X = alpha*B. 52 | C> 53 | C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. 54 | C> \endverbatim 55 | C> 56 | C> \param[in] UPLO 57 | C> \verbatim 58 | C> UPLO is CHARACTER*1 59 | C> On entry, UPLO specifies whether the matrix A is an upper 60 | Cor 61 | C> lower triangular matrix as follows: 62 | C> 63 | C> UPLO = 'U' or 'u' A is an upper triangular matrix. 64 | C> 65 | C> UPLO = 'L' or 'l' A is a lower triangular matrix. 66 | C> \endverbatim 67 | C> 68 | C> \param[in] TRANSA 69 | C> \verbatim 70 | C> TRANSA is CHARACTER*1 71 | C> On entry, TRANSA specifies the form of op( A ) to be used 72 | Cin 73 | C> the matrix multiplication as follows: 74 | C> 75 | C> TRANSA = 'N' or 'n' op( A ) = A. 76 | C> 77 | C> TRANSA = 'T' or 't' op( A ) = A**T. 78 | C> 79 | C> TRANSA = 'C' or 'c' op( A ) = A**T. 80 | C> \endverbatim 81 | C> 82 | C> \param[in] DIAG 83 | C> \verbatim 84 | C> DIAG is CHARACTER*1 85 | C> On entry, DIAG specifies whether or not A is unit 86 | Ctriangular 87 | C> as follows: 88 | C> 89 | C> DIAG = 'U' or 'u' A is assumed to be unit triangular. 90 | C> 91 | C> DIAG = 'N' or 'n' A is not assumed to be unit 92 | C> triangular. 93 | C> \endverbatim 94 | C> 95 | C> \param[in] M 96 | C> \verbatim 97 | C> M is INTEGER 98 | C> On entry, M specifies the number of rows of B. M must be 99 | Cat 100 | C> least zero. 101 | C> \endverbatim 102 | C> 103 | C> \param[in] N 104 | C> \verbatim 105 | C> N is INTEGER 106 | C> On entry, N specifies the number of columns of B. N must 107 | Cbe 108 | C> at least zero. 109 | C> \endverbatim 110 | C> 111 | C> \param[in] ALPHA 112 | C> \verbatim 113 | C> ALPHA is REAL 114 | C> On entry, ALPHA specifies the scalar alpha. When alpha 115 | Cis 116 | C> zero then A is not referenced and B need not be set 117 | Cbefore 118 | C> entry. 119 | C> \endverbatim 120 | C> 121 | C> \param[in] A 122 | C> \verbatim 123 | C> A is REAL array, dimension ( LDA, k ), 124 | C> where k is m when SIDE = 'L' or 'l' 125 | C> and k is n when SIDE = 'R' or 'r'. 126 | C> Before entry with UPLO = 'U' or 'u', the leading k by 127 | Ck 128 | C> upper triangular part of the array A must contain the 129 | Cupper 130 | C> triangular matrix and the strictly lower triangular part 131 | Cof 132 | C> A is not referenced. 133 | C> Before entry with UPLO = 'L' or 'l', the leading k by 134 | Ck 135 | C> lower triangular part of the array A must contain the 136 | Clower 137 | C> triangular matrix and the strictly upper triangular part 138 | Cof 139 | C> A is not referenced. 140 | C> Note that when DIAG = 'U' or 'u', the diagonal elements 141 | Cof 142 | C> A are not referenced either, but are assumed to be 143 | Cunity. 144 | C> \endverbatim 145 | C> 146 | C> \param[in] LDA 147 | C> \verbatim 148 | C> LDA is INTEGER 149 | C> On entry, LDA specifies the first dimension of A as 150 | Cdeclared 151 | C> in the calling (sub) program. When SIDE = 'L' or 'l' 152 | Cthen 153 | C> LDA must be at least max( 1, m ), when SIDE = 'R' or 154 | C'r' 155 | C> then LDA must be at least max( 1, n ). 156 | C> \endverbatim 157 | C> 158 | C> \param[in,out] B 159 | C> \verbatim 160 | C> B is REAL array, dimension ( LDB, N ) 161 | C> Before entry, the leading m by n part of the array B 162 | Cmust 163 | C> contain the right-hand side matrix B, and on exit 164 | Cis 165 | C> overwritten by the solution matrix X. 166 | C> \endverbatim 167 | C> 168 | C> \param[in] LDB 169 | C> \verbatim 170 | C> LDB is INTEGER 171 | C> On entry, LDB specifies the first dimension of B as 172 | Cdeclared 173 | C> in the calling (sub) program. LDB must be at 174 | Cleast 175 | C> max( 1, m ). 176 | C> \endverbatim 177 | C 178 | C Authors: 179 | C ======== 180 | C 181 | C> \author Univ. of Tennessee 182 | C> \author Univ. of California Berkeley 183 | C> \author Univ. of Colorado Denver 184 | C> \author NAG Ltd. 185 | C 186 | C> \date December 2016 187 | C 188 | C> \ingroup single_blas_level3 189 | C 190 | C> \par Further Details: 191 | C ===================== 192 | C> 193 | C> \verbatim 194 | C> 195 | C> Level 3 Blas routine. 196 | C> 197 | C> 198 | C> -- Written on 8-February-1989. 199 | C> Jack Dongarra, Argonne National Laboratory. 200 | C> Iain Duff, AERE Harwell. 201 | C> Jeremy Du Croz, Numerical Algorithms Group Ltd. 202 | C> Sven Hammarling, Numerical Algorithms Group Ltd. 203 | C> \endverbatim 204 | C> 205 | C ===================================================================== 206 | SUBROUTINE strsm(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 207 | C 208 | C -- Reference BLAS level3 routine (version 3.7.0) -- 209 | C -- Reference BLAS is a software package provided by Univ. of 210 | C Tennessee, -- 211 | C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG 212 | C Ltd..-- 213 | C December 2016 214 | C 215 | C .. Scalar Arguments .. 216 | REAL ALPHA 217 | INTEGER LDA,LDB,M,N 218 | CHARACTER DIAG,SIDE,TRANSA,UPLO 219 | C .. 220 | C .. Array Arguments .. 221 | REAL A(lda,*),B(ldb,*) 222 | C .. 223 | C 224 | C ===================================================================== 225 | C 226 | C .. External Functions .. 227 | LOGICAL LSAME 228 | EXTERNAL lsame 229 | C .. 230 | C .. External Subroutines .. 231 | EXTERNAL xerbla 232 | C .. 233 | C .. Intrinsic Functions .. 234 | INTRINSIC max 235 | C .. 236 | C .. Local Scalars .. 237 | REAL atmp 238 | REAL TEMP 239 | INTEGER I,INFO,J,K,NROWA 240 | LOGICAL LSIDE,NOUNIT,UPPER 241 | C .. 242 | C .. Parameters .. 243 | REAL ONE,ZERO 244 | REAL TOL 245 | parameter(one=1.0e+0,zero=0.0e+0) 246 | parameter(tol=1.0e-10) 247 | C .. 248 | C 249 | C Test the input parameters. 250 | C 251 | lside = lsame(side,'L') 252 | IF (lside) THEN 253 | nrowa = m 254 | ELSE 255 | nrowa = n 256 | END IF 257 | nounit = lsame(diag,'N') 258 | upper = lsame(uplo,'U') 259 | C 260 | info = 0 261 | IF ((.NOT.lside) .AND. (.NOT.lsame(side,'R'))) THEN 262 | info = 1 263 | ELSE IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN 264 | info = 2 265 | ELSE IF ((.NOT.lsame(transa,'N')) .AND. 266 | + (.NOT.lsame(transa,'T')) .AND. 267 | + (.NOT.lsame(transa,'C'))) THEN 268 | info = 3 269 | ELSE IF ((.NOT.lsame(diag,'U')) .AND. (.NOT.lsame(diag,'N')))THEN 270 | info = 4 271 | ELSE IF (m.LT.0) THEN 272 | info = 5 273 | ELSE IF (n.LT.0) THEN 274 | info = 6 275 | ELSE IF (lda.LT.max(1,nrowa)) THEN 276 | info = 9 277 | ELSE IF (ldb.LT.max(1,m)) THEN 278 | info = 11 279 | END IF 280 | IF (info.NE.0) THEN 281 | CALL xerbla('STRSM ',info) 282 | RETURN 283 | END IF 284 | C 285 | C Quick return if possible. 286 | C 287 | IF (m.EQ.0 .OR. n.EQ.0) RETURN 288 | C 289 | C And when alpha.eq.zero. 290 | C 291 | IF (alpha.EQ.zero) THEN 292 | DO 20 j = 1,n 293 | DO 10 i = 1,m 294 | b(i,j) = zero 295 | 10 CONTINUE 296 | 20 CONTINUE 297 | RETURN 298 | END IF 299 | C 300 | C Start the operations. 301 | C 302 | IF (lside) THEN 303 | IF (lsame(transa,'N')) THEN 304 | C 305 | C Form B := alpha*inv( A )*B. 306 | C 307 | IF (upper) THEN 308 | DO 60 j = 1,n 309 | IF (alpha.NE.one) THEN 310 | DO 30 i = 1,m 311 | b(i,j) = alpha*b(i,j) 312 | 30 CONTINUE 313 | END IF 314 | DO 50 k = m,1,-1 315 | IF (b(k,j).NE.zero) THEN 316 | ! IF (nounit) b(k,j) = b(k,j)/a(k,k) 317 | IF (nounit)then 318 | atmp=0.0e+0 319 | if(a(k,k).gt.tol)atmp=1.0e+0/a(k,k) 320 | b(k,j) = b(k,j)*atmp 321 | endif 322 | DO 40 i = 1,k - 1 323 | b(i,j) = b(i,j) - b(k,j)*a(i,k) 324 | 40 CONTINUE 325 | END IF 326 | 50 CONTINUE 327 | 60 CONTINUE 328 | ELSE 329 | DO 100 j = 1,n 330 | IF (alpha.NE.one) THEN 331 | DO 70 i = 1,m 332 | b(i,j) = alpha*b(i,j) 333 | 70 CONTINUE 334 | END IF 335 | DO 90 k = 1,m 336 | IF (b(k,j).NE.zero) THEN 337 | ! IF (nounit) b(k,j) = b(k,j)/a(k,k) 338 | IF (nounit)then 339 | atmp=0.0e+0 340 | if(a(k,k).gt.tol)atmp=1.0e+0/a(k,k) 341 | b(k,j) = b(k,j)*atmp 342 | endif 343 | DO 80 i = k + 1,m 344 | b(i,j) = b(i,j) - b(k,j)*a(i,k) 345 | 80 CONTINUE 346 | END IF 347 | 90 CONTINUE 348 | 100 CONTINUE 349 | END IF 350 | ELSE 351 | C 352 | C Form B := alpha*inv( A**T )*B. 353 | C 354 | IF (upper) THEN 355 | DO 130 j = 1,n 356 | DO 120 i = 1,m 357 | temp = alpha*b(i,j) 358 | DO 110 k = 1,i - 1 359 | temp = temp - a(k,i)*b(k,j) 360 | 110 CONTINUE 361 | ! IF (nounit) temp = temp/a(i,i) 362 | IF (nounit)then 363 | atmp=0.0e+0 364 | if(a(i,i).gt.tol)atmp=1.0e+0/a(i,i) 365 | temp = temp*atmp 366 | endif 367 | b(i,j) = temp 368 | 120 CONTINUE 369 | 130 CONTINUE 370 | ELSE 371 | DO 160 j = 1,n 372 | DO 150 i = m,1,-1 373 | temp = alpha*b(i,j) 374 | DO 140 k = i + 1,m 375 | temp = temp - a(k,i)*b(k,j) 376 | 140 CONTINUE 377 | ! IF (nounit) temp = temp/a(i,i) 378 | IF (nounit)then 379 | atmp=0.0e+0 380 | if(a(i,i).gt.tol)atmp=1.0e+0/a(i,i) 381 | temp = temp*atmp 382 | endif 383 | b(i,j) = temp 384 | 150 CONTINUE 385 | 160 CONTINUE 386 | END IF 387 | END IF 388 | ELSE 389 | IF (lsame(transa,'N')) THEN 390 | C 391 | C Form B := alpha*B*inv( A ). 392 | C 393 | IF (upper) THEN 394 | DO 210 j = 1,n 395 | IF (alpha.NE.one) THEN 396 | DO 170 i = 1,m 397 | b(i,j) = alpha*b(i,j) 398 | 170 CONTINUE 399 | END IF 400 | DO 190 k = 1,j - 1 401 | IF (a(k,j).NE.zero) THEN 402 | DO 180 i = 1,m 403 | b(i,j) = b(i,j) - a(k,j)*b(i,k) 404 | 180 CONTINUE 405 | END IF 406 | 190 CONTINUE 407 | IF (nounit) THEN 408 | ! temp = one/a(j,j) 409 | atmp=0.0e+0 410 | if(a(j,j).gt.tol)atmp=1.0e+0/a(j,j) 411 | temp = one*atmp 412 | DO 200 i = 1,m 413 | b(i,j) = temp*b(i,j) 414 | 200 CONTINUE 415 | END IF 416 | 210 CONTINUE 417 | ELSE 418 | DO 260 j = n,1,-1 419 | IF (alpha.NE.one) THEN 420 | DO 220 i = 1,m 421 | b(i,j) = alpha*b(i,j) 422 | 220 CONTINUE 423 | END IF 424 | DO 240 k = j + 1,n 425 | IF (a(k,j).NE.zero) THEN 426 | DO 230 i = 1,m 427 | b(i,j) = b(i,j) - a(k,j)*b(i,k) 428 | 230 CONTINUE 429 | END IF 430 | 240 CONTINUE 431 | IF (nounit) THEN 432 | ! temp = one/a(j,j) 433 | atmp=0.0e+0 434 | if(a(j,j).gt.tol)atmp=1.0e+0/a(j,j) 435 | temp = one*atmp 436 | DO 250 i = 1,m 437 | b(i,j) = temp*b(i,j) 438 | 250 CONTINUE 439 | END IF 440 | 260 CONTINUE 441 | END IF 442 | ELSE 443 | C 444 | C Form B := alpha*B*inv( A**T ). 445 | C 446 | IF (upper) THEN 447 | DO 310 k = n,1,-1 448 | IF (nounit) THEN 449 | ! temp = one/a(k,k) 450 | atmp=0.e+0 451 | if(a(k,k).gt.tol)atmp=1.e+0/a(k,k) 452 | temp = one*atmp 453 | DO 270 i = 1,m 454 | b(i,k) = temp*b(i,k) 455 | 270 CONTINUE 456 | END IF 457 | DO 290 j = 1,k - 1 458 | IF (a(j,k).NE.zero) THEN 459 | temp = a(j,k) 460 | DO 280 i = 1,m 461 | b(i,j) = b(i,j) - temp*b(i,k) 462 | 280 CONTINUE 463 | END IF 464 | 290 CONTINUE 465 | IF (alpha.NE.one) THEN 466 | DO 300 i = 1,m 467 | b(i,k) = alpha*b(i,k) 468 | 300 CONTINUE 469 | END IF 470 | 310 CONTINUE 471 | ELSE 472 | DO 360 k = 1,n 473 | IF (nounit) THEN 474 | ! temp = one/a(k,k) 475 | atmp=0.0e+0 476 | if(a(k,k).gt.tol)atmp=1.0e+0/a(k,k) 477 | temp = one*atmp 478 | DO 320 i = 1,m 479 | b(i,k) = temp*b(i,k) 480 | 320 CONTINUE 481 | END IF 482 | DO 340 j = k + 1,n 483 | IF (a(j,k).NE.zero) THEN 484 | temp = a(j,k) 485 | DO 330 i = 1,m 486 | b(i,j) = b(i,j) - temp*b(i,k) 487 | 330 CONTINUE 488 | END IF 489 | 340 CONTINUE 490 | IF (alpha.NE.one) THEN 491 | DO 350 i = 1,m 492 | b(i,k) = alpha*b(i,k) 493 | 350 CONTINUE 494 | END IF 495 | 360 CONTINUE 496 | END IF 497 | END IF 498 | END IF 499 | C 500 | RETURN 501 | C 502 | C End of STRSM . 503 | C 504 | END 505 | -------------------------------------------------------------------------------- /src/smbfct.f: -------------------------------------------------------------------------------- 1 | c####################################################################### 2 | c# this is subroutine "SMBFCT" as given in : 'Computer Solutions # 3 | c# of Large Sparse Positive Definite Systems' by A. George and # 4 | c# J.W.-H. Liu, 1981, Prentice Hall, Inc. Englewood Cliffs, # 5 | c# New Jersey 07632, pp. 149-151; # 6 | c# Modified for my own # 7 | c####################################################################### 8 | 9 | 10 | C----- SUBROUTINE SMBFCT 11 | C**************************************************************** 1. 12 | C**************************************************************** 2. 13 | C********* SMBFCT ..... SYMBOLIC FACTORIZATION ******** 3. 14 | C**************************************************************** 4. 15 | C**************************************************************** 5. 16 | C 6. 17 | C PURPOSE - THIS ROUTINE PERFORMS SYMBOLIC FACTORIZATION 7. 18 | C ON A PERMUTED LINEAR SYSTEM AND IT ALSO SETS UP THE 8. 19 | C COMPRESSED DATA STRUCTURE FOR THE SYSTEM. 9. 20 | C 10. 21 | C INPUT PARAMETERS - 11. 22 | C NEQNS - NUMBER OF EQUATIONS. 12. 23 | C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. 13. 24 | C (PERM, INVP) - THE PERMUTATION VECTOR AND ITS INVERSE. 14. 25 | C 15. 26 | C UPDATED PARAMETERS - 16. 27 | C MAXSUB - SIZE OF THE SUBSCRIPT ARRAY NZSUB. ON RETURN, 17. 28 | C IT CONTAINS THE NUMBER OF SUBSCRIPTS USED 18. 29 | C 19. 30 | C OUTPUT PARAMETERS - 20. 31 | C XLNZ - INDEX INTO THE NONZERO STORAGE VECTOR LNZ. 21. 32 | C (XNZSUB, NZSUB) - THE COMPRESSED SUBSCRIPT VECTORS. 22. 33 | C MAXLNZ - THE NUMBER OF NONZEROS FOUND. 23. 34 | C FLAG - ERROR FLAG. POSITIVE VALUE INDICATES THAT. 24. 35 | C NZSUB ARRAY IS TOO SMALL. 25. 36 | C 26. 37 | C WORKING PARAMETERS - 27. 38 | C MRGLNK - A VECTOR OF SIZE NEQNS. AT THE KTH STEP, 28. 39 | C MRGLNK(K), MRGLNK(MRGLNK(K)) , ......... 29. 40 | C IS A LIST CONTAINING ALL THOSE COLUMNS L(*,J) 30. 41 | C WITH J LESS THAN K, SUCH THAT ITS FIRST OFF- 31. 42 | C DIAGONAL NONZERO IS L(K,J). THUS, THE 32. 43 | C NONZERO STRUCTURE OF COLUMN L(*,K) CAN BE FOUND 33. 44 | C BY MERGING THAT OF SUCH COLUMNS L(*,J) WITH 34. 45 | C THE STRUCTURE OF A(*,K). 35. 46 | C RCHLNK - A VECTOR OF SIZE NEQNS. IT IS USED TO ACCUMULATE 36. 47 | C THE STRUCTURE OF EACH COLUMN L(*,K). AT THE 37. 48 | C END OF THE KTH STEP, 38. 49 | C RCHLNK(K), RCHLNK(RCHLNK(K)), ........ 39. 50 | C IS THE LIST OF POSITIONS OF NONZEROS IN COLUMN K 40. 51 | C OF THE FACTOR L. 41. 52 | C MARKER - AN INTEGER VECTOR OF LENGTH NEQNS. IT IS USED 42. 53 | C TO TEST IF MASS SYMBOLIC ELIMINATION CAN BE 43. 54 | C PERFORMED. THAT IS, IT IS USED TO CHECK WHETHER 44. 55 | C THE STRUCTURE OF THE CURRENT COLUMN K BEING 45. 56 | C PROCESSED IS COMPLETELY DETERMINED BY THE SINGLE 46. 57 | C COLUMN MRGLNK(K). 47. 58 | C 48. 59 | C**************************************************************** 49. 60 | C 50. 61 | SUBROUTINE SMBFCT ( NEQNS, XADJ, ADJNCY, PERM, INVP, 51. 62 | 1 XLNZ, MAXLNZ, XNZSUB, NZSUB, MAXSUB, 52. 63 | 1 RCHLNK, MRGLNK, MARKER, FLAG ) 53. 64 | C 54. 65 | C**************************************************************** 55. 66 | C 56. 67 | INTEGER ADJNCY(*), INVP(*), MRGLNK(*), NZSUB(*), 57. 68 | 1 PERM(*), RCHLNK(*), MARKER(*) 58. 69 | INTEGER XADJ(*), XLNZ(*), XNZSUB(*), 59. 70 | 1 FLAG, I, INZ, J, JSTOP, JSTRT, K, KNZ, 60. 71 | 1 KXSUB, MRGK, LMAX, M, MAXLNZ, MAXSUB, 61. 72 | 1 NABOR, NEQNS, NODE, NP1, NZBEG, NZEND, 62. 73 | 1 RCHM, MRKFLG 63. 74 | C 64. 75 | C**************************************************************** 65. 76 | C 66. 77 | C ------------------ 67. 78 | C INITIALIZATION ... 68. 79 | C ------------------ 69. 80 | NZBEG = 1 70. 81 | NZEND = 0 71. 82 | XLNZ(1) = 1 72. 83 | DO 100 K = 1, NEQNS 73. 84 | MRGLNK(K) = 0 74. 85 | MARKER(K) = 0 75. 86 | 100 CONTINUE 76. 87 | C -------------------------------------------------- 77. 88 | C FOR EACH COLUMN ......... . KNZ COUNTS THE NUMBER 78. 89 | C OF NONZEROS IN COLUMN K ACCUMULATED IN RCHLNK. 79. 90 | C -------------------------------------------------- 80. 91 | NP1 = NEQNS + 1 81. 92 | DO 1500 K = 1, NEQNS 82. 93 | KNZ = 0 83. 94 | MRGK = MRGLNK(K) 84. 95 | MRKFLG = 0 85. 96 | MARKER(K) = K 86. 97 | IF (MRGK .NE. 0 ) MARKER(K) = MARKER(MRGK) 87. 98 | XNZSUB(K) = NZEND 88. 99 | NODE = PERM(K) 89. 100 | JSTRT = XADJ(NODE) 90. 101 | JSTOP = XADJ(NODE+1) - 1 91. 102 | IF (JSTRT.GT.JSTOP) GO TO 1500 92. 103 | C ------------------------------------------- 93. 104 | C USE RCHLNK TO LINK THROUGH THE STRUCTURE OF 94. 105 | C A(*,K) BELOW DIAGONAL 95. 106 | C ------------------------------------------- 96. 107 | RCHLNK(K) = NP1 97. 108 | DO 300 J = JSTRT, JSTOP 98. 109 | NABOR = ADJNCY(J) 99. 110 | NABOR = INVP(NABOR) 100. 111 | IF ( NABOR .LE. K ) GO TO 300 101. 112 | RCHM = K 102. 113 | 200 M = RCHM 103. 114 | RCHM = RCHLNK(M) 104. 115 | IF ( RCHM .LE. NABOR ) GO TO 200 105. 116 | KNZ = KNZ+1 106. 117 | RCHLNK(M) = NABOR 107. 118 | RCHLNK(NABOR) = RCHM 108. 119 | IF ( MARKER(NABOR) .NE. MARKER(K) ) MRKFLG = 1 109. 120 | 300 CONTINUE 110. 121 | C -------------------------------------- 111. 122 | C TEST FOR MASS SYMBOLIC ELIMINATION ... 112. 123 | C -------------------------------------- 113. 124 | LMAX = 0 114. 125 | IF ( MRKFLG .NE. 0 .OR. MRGK .EQ. 0 ) GO TO 350 115. 126 | IF ( MRGLNK(MRGK) .NE. 0 ) GO TO 350 116. 127 | XNZSUB(K) = XNZSUB(MRGK) + 1 117. 128 | KNZ = XLNZ(MRGK+1) - (XLNZ(MRGK) + 1) 118. 129 | GO TO 1400 119. 130 | C ----------------------------------------------- 120. 131 | C LINK THROUGH EACH COLUMN I THAT AFFECTS L(*,K). 121. 132 | C ----------------------------------------------- 122. 133 | 350 I = K 123. 134 | 400 I = MRGLNK(I) 124. 135 | IF (I.EQ.0) GO TO 800 125. 136 | INZ = XLNZ(I+1) - (XLNZ(I)+1) 126. 137 | JSTRT = XNZSUB(I) + 1 127. 138 | JSTOP = XNZSUB(I) + INZ 128. 139 | IF (INZ.LE.LMAX) GO TO 500 129. 140 | LMAX = INZ 130. 141 | XNZSUB(K) = JSTRT 131. 142 | C ----------------------------------------------- 132. 143 | C MERGE STRUCTURE OF L(*,I) IN NZSUB INTO RCHLNK. 133. 144 | C ----------------------------------------------- 134. 145 | 500 RCHM = K 135. 146 | DO 700 J = JSTRT, JSTOP 136. 147 | NABOR = NZSUB(J) 137. 148 | 600 M = RCHM 138. 149 | RCHM = RCHLNK(M) 139. 150 | IF (RCHM.LT.NABOR) GO TO 600 140. 151 | IF (RCHM.EQ.NABOR) GO TO 700 141. 152 | KNZ = KNZ+1 142. 153 | RCHLNK(M) = NABOR 143. 154 | RCHLNK(NABOR) = RCHM 144. 155 | RCHM = NABOR 145. 156 | 700 CONTINUE 146. 157 | GO TO 400 147. 158 | C ------------------------------------------------------ 148. 159 | C CHECK IF SUBSCRIPTS DUPLICATE THOSE OF ANOTHER COLUMN. 149. 160 | C ------------------------------------------------------ 150. 161 | 800 IF (KNZ.EQ.LMAX) GO TO 1400 151. 162 | C ----------------------------------------------- 152. 163 | C OR IF TAIL OF K-1ST COLUMN MATCHES HEAD OF KTH. 153. 164 | C ----------------------------------------------- 154. 165 | IF (NZBEG.GT.NZEND) GO TO 1200 155. 166 | I = RCHLNK(K) 156. 167 | DO 900 JSTRT=NZBEG,NZEND 157. 168 | IF (NZSUB(JSTRT)-I) 900, 1000, 1200 158. 169 | 900 CONTINUE 159. 170 | GO TO 1200 160. 171 | 1000 XNZSUB(K) = JSTRT 161. 172 | DO 1100 J=JSTRT,NZEND 162. 173 | IF (NZSUB(J).NE.I) GO TO 1200 163. 174 | I = RCHLNK(I) 164. 175 | IF (I.GT.NEQNS) GO TO 1400 165. 176 | 1100 CONTINUE 166. 177 | NZEND = JSTRT - 1 167. 178 | C ---------------------------------------- 168. 179 | C COPY THE STRUCTURE OF L(*,K) FROM RCHLNK 169. 180 | C TO THE DATA STRUCTURE (XNZSUB, NZSUB). 170. 181 | C ---------------------------------------- 171. 182 | 1200 NZBEG = NZEND + 1 172. 183 | NZEND = NZEND + KNZ 173. 184 | IF (NZEND.GT.MAXSUB) GO TO 1600 174. 185 | I = K 175. 186 | DO 1300 J=NZBEG,NZEND 176. 187 | I = RCHLNK(I) 177. 188 | NZSUB(J) = I 178. 189 | MARKER(I) = K 179. 190 | 1300 CONTINUE 180. 191 | XNZSUB(K) = NZBEG 181. 192 | MARKER(K) = K 182. 193 | C -------------------------------------------------------- 183. 194 | C UPDATE THE VECTOR MRGLNK. NOTE COLUMN L(*,K) JUST FOUND 184. 195 | C IS REQUIRED TO DETERMINE COLUMN L(*,J), WHERE 185. 196 | C L(J,K) IS THE FIRST NONZERO IN L(*,K) BELOW DIAGONAL. 186. 197 | C -------------------------------------------------------- 187. 198 | 1400 IF (KNZ.LE.1) GO TO 1500 188. 199 | KXSUB = XNZSUB(K) 189. 200 | I = NZSUB(KXSUB) 190. 201 | MRGLNK(K) = MRGLNK(I) 191. 202 | MRGLNK(I) = K 192. 203 | 1500 XLNZ(K+1) = XLNZ(K) + KNZ 193. 204 | MAXLNZ = XLNZ(NEQNS) - 1 194. 205 | MAXSUB = XNZSUB(NEQNS) 195. 206 | XNZSUB(NEQNS+1) = XNZSUB(NEQNS) 196. 207 | FLAG = 0 197. 208 | RETURN 198. 209 | C ---------------------------------------------------- 199. 210 | C ERROR - INSUFFICIENT STORAGE FOR NONZERO SUBSCRIPTS. 200. 211 | C ---------------------------------------------------- 201. 212 | 1600 FLAG = 1 202. 213 | RETURN 203. 214 | END 204. 215 | 216 | 217 | 218 | -------------------------------------------------------------------------------- /test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | if (NOT TARGET "test-drive::test-drive") 2 | find_package("test-drive" REQUIRED) 3 | endif() 4 | 5 | macro(ADDTEST name) 6 | add_executable(test_${name} test_${name}.f90 ${test-srcs}) 7 | target_link_libraries(test_${name} "${PROJECT_NAME}" "test-drive::test-drive" 8 | ) 9 | target_compile_definitions( 10 | "test_${name}" 11 | PRIVATE 12 | "-D_DP=1" 13 | "-D_METIS=${WITH_METIS}" 14 | "-D_PARDISO=${WITH_MKLPARDISO}" 15 | "-D_SPAINV=${WITH_SPAINV}" 16 | ) 17 | add_test(NAME ${name} 18 | COMMAND $ ${CMAKE_CURRENT_BINARY_DIR} 19 | WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) 20 | endmacro(ADDTEST) 21 | 22 | list( 23 | APPEND fyppFlags 24 | "-I${PROJECT_SOURCE_DIR}/src" 25 | ) 26 | 27 | set( 28 | test-srcs 29 | modtest_common.f90 30 | modtest_coo.f90 31 | modtest_crs64.f90 32 | modtest_crs.f90 33 | modtest_random.f90 34 | ) 35 | 36 | ADDTEST(sparse) 37 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | PROGS_SRC = test_sparse.f90 2 | 3 | PATHTESST = ../test-drive/src 4 | LIBTEST = libtestrive.a 5 | OBJTEST = testdrive.o 6 | 7 | NAME = sparse 8 | 9 | CPPFLAGS += -I../src/ -I. 10 | 11 | OBJS = modtest_common.o modtest_coo.o modtest_crs.o modtest_crs64.o modtest_random.o 12 | 13 | LIB = $(patsubst %, ../src/lib%.a, $(NAME)) 14 | 15 | PROGS = $(PROGS_SRC:.f90=) 16 | TESTPROGS = $(PROGS:=TEST) 17 | 18 | .PHONY: all clean test $(TESTPROGS) 19 | 20 | all: $(PROGS) 21 | 22 | test: $(TESTPROGS) 23 | 24 | $(TESTPROGS): 25 | ./$(@:TEST=) 26 | 27 | clean: 28 | $(RM) $(PROGS) $(OBJS) $(CLEAN_FILES) *.o* *.*mod *.a 29 | 30 | $(LIBTEST): $(OBJTEST) 31 | ar rcs $@ $^ 32 | 33 | testdrive.o: $(PATHTESST)/testdrive.F90 34 | $(FC) $(FFLAGS) $(CPPFLAGS) -c $< 35 | 36 | %.o: %.f90 $(LIBTEST) 37 | $(FC) $(FFLAGS) $(CPPFLAGS) -c $< 38 | 39 | $(PROGS): %: $(OBJS) $(LIBTEST) $(LIB) %.o 40 | $(FC) $(FFLAGS) $(CPPFLAGS) -o $@ $^ $(FLIBS) 41 | 42 | modtest_common.o: $(LIB) 43 | modtest_coo.o: modtest_common.o $(LIB) testdrive.o 44 | modtest_crs.o: modtest_common.o $(LIB) testdrive.o 45 | modtest_crs64.o: modtest_common.o $(LIB) testdrive.o 46 | modtest_random.o: $(LIB) testdrive.o 47 | test_sparse.o: modtest_coo.o modtest_crs.o modtest_crs64.o modtest_random.o testdrive.o 48 | -------------------------------------------------------------------------------- /test/modtest_common.f90: -------------------------------------------------------------------------------- 1 | module modtest_common 2 | #if (_DP==0) 3 | use, intrinsic :: iso_fortran_env, only: output_unit, wp => real32 4 | #else 5 | use, intrinsic :: iso_fortran_env, only: output_unit, wp => real64 6 | #endif 7 | use modsparse, only: gen_sparse, coosparse 8 | implicit none 9 | private 10 | public :: addval_coo, getmat, matcheck, printmat 11 | 12 | real(wp), parameter, public :: tol_wp = epsilon(1._wp) * 10**4 13 | 14 | logical, parameter, public :: verbose = .false. 15 | 16 | integer, parameter, public :: ia(16) = [1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 4, 4, 5, 5, 5, 6] 17 | integer, parameter, public :: ja(16) = [1, 3, 4, 5, 6, 6, 5, 1, 3, 4, 4, 6, 1, 2, 5, 6] 18 | real(wp), parameter, public :: a(16) = [real(wp):: 11, 13, 14, 15, 16, 22, 25, 31, 33, 34& 19 | , 44, 46, 51, 52, 55, 66] 20 | real(wp), parameter, public :: aspsd(16) = [real(wp):: 101, 13, 14, 15, 16, 0, 0, 31, 303, 34& 21 | , 404, 46, 51, 52, 505, 606] 22 | 23 | integer, parameter, public :: iaspsdf(*) = [1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 5, 6] 24 | integer, parameter, public :: jaspsdf(*) = [1, 2, 3, 4, 5, 6, 2, 4, 5, 6, 3, 4, 5, 6, 4, 5, 6] 25 | real(wp), parameter, public :: aspsdf(*) = [real(wp):: 6, 3, 3, 2, 2, 2, 3, 1, 1, 1, 3, 1, 1, 1& 26 | , 2, 2, 2] 27 | 28 | integer, parameter, public :: iaspsdf1(*) = [1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 5, 6] 29 | integer, parameter, public :: jaspsdf1(*) = [1, 2, 3, 4, 2, 3, 5, 6, 3, 4, 5, 6, 4, 5, 6, 5, 6] 30 | real(wp), parameter, public :: aspsdf1(*) = [real(wp):: 2, 1, 2, 1, 3, 3, 1, 1, 6, 3, 3, 2, 3, 1& 31 | , 1, 1, 2, 2] 32 | 33 | contains 34 | subroutine addval_coo(coo, nrow, ncol, ia, ja, a, iat, jat, at, mat) 35 | type(coosparse), intent(inout) :: coo 36 | integer, intent(in) :: nrow, ncol 37 | integer, intent(in) :: ia(:), ja(:) 38 | real(wp), intent(in) :: a(:) 39 | integer, allocatable , intent(out), optional :: iat(:), jat(:) 40 | real(wp), allocatable , intent(out), optional :: at(:) 41 | real(wp), intent(out), optional :: mat(:,:) 42 | 43 | integer :: i, j 44 | real(wp) :: val 45 | 46 | if(present(mat))then 47 | if(nrow.ne.size(mat,1) .or. ncol.ne.size(mat,2))return 48 | endif 49 | 50 | do i = 1, size(ia) 51 | call coo%add(ia(i), ja(i), a(i)) 52 | enddo 53 | 54 | if(.not.present(iat).or..not.present(jat).or..not.present(at).or..not.present(mat))return 55 | 56 | allocate(iat(0), jat(0), at(0)) 57 | do i = 1, maxval(ia) 58 | do j = 1, maxval(ja) 59 | val = coo%get(i, j) 60 | if(present(mat))then 61 | if(i.le.nrow.and.j.le.ncol)mat(i, j) = val 62 | endif 63 | if (val .ne. 0._wp) then 64 | iat = [iat, i] 65 | jat = [jat, j] 66 | at = [at, val] 67 | endif 68 | enddo 69 | enddo 70 | 71 | end subroutine 72 | 73 | function getmat(sparse) result(mat) 74 | class(gen_sparse), intent(inout) :: sparse 75 | 76 | real(wp) :: mat(sparse%getdim(1), sparse%getdim(2)) 77 | 78 | integer :: i, j 79 | 80 | mat = -1 81 | 82 | do i = 1, sparse%getdim(1) 83 | do j = 1, sparse%getdim(2) 84 | mat(i, j) = sparse%get(i, j) 85 | enddo 86 | enddo 87 | 88 | end function 89 | 90 | pure function matcheck(nrow, ncol, ia, ja, a, lvalid) result(mat) 91 | integer, intent(in) :: nrow, ncol, ia(:), ja(:) 92 | real(wp), intent(in) :: a(:) 93 | logical, intent(in) :: lvalid(:) 94 | 95 | real(wp) :: mat(nrow, ncol) 96 | integer :: i 97 | 98 | mat = 0 99 | do i = 1, size(ia) 100 | if(lvalid(i))then 101 | mat(ia(i), ja(i)) = a(i) 102 | endif 103 | enddo 104 | 105 | end function 106 | 107 | subroutine printmat(mat) 108 | real(wp), intent(in) :: mat(:,:) 109 | 110 | integer :: i 111 | 112 | write(output_unit, '(a)')repeat('*',size(mat, 1)) 113 | 114 | do i = 1, size(mat, 1) 115 | write(output_unit, '(*(g0.5,1x))')mat(i,:) 116 | enddo 117 | 118 | write(output_unit, '(a)')repeat('*',size(mat, 1)) 119 | end subroutine 120 | 121 | end module 122 | -------------------------------------------------------------------------------- /test/modtest_random.f90: -------------------------------------------------------------------------------- 1 | module modtest_random 2 | #if (_DP==0) 3 | use, intrinsic :: iso_fortran_env, only: int64, wp => real32 4 | #else 5 | use, intrinsic :: iso_fortran_env, only: int64, wp => real64 6 | #endif 7 | use testdrive, only: new_unittest, unittest_type, error_type, check 8 | use modrandom, only: setseed, rand_stdnormal 9 | use modtest_common, only: tol_wp, verbose 10 | implicit none 11 | private 12 | 13 | public :: collect_random 14 | 15 | integer, parameter :: sparse_unit = 556 16 | 17 | contains 18 | 19 | !> Collect all exported unit tests 20 | subroutine collect_random(testsuite) 21 | !> Collection of tests 22 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 23 | 24 | !how to test: getordering, print, printsquare, save, sort 25 | 26 | testsuite = [ & 27 | new_unittest("stdnormal", test_stdnormal) & 28 | ] 29 | 30 | end subroutine collect_random 31 | 32 | !CONSTRUCTOR + GETDIM + ISSQUARE 33 | subroutine test_stdnormal(error) 34 | type(error_type), allocatable, intent(out) :: error 35 | 36 | integer, parameter :: n = 100000 37 | integer :: i 38 | real(wp) :: vector(n) 39 | real(wp) :: mean, sd 40 | 41 | call setseed(1) 42 | 43 | vector = [(rand_stdnormal(), i = 1, n)] 44 | 45 | mean = sum(vector) / n 46 | sd = sqrt(sum((vector - mean)**2)/n) 47 | 48 | call check(error, abs(int(mean * 1000)/1000._wp - 0._wp) < tol_wp, more = 'Mean different than 0') 49 | if(allocated(error))return 50 | 51 | call check(error, abs(int(sd * 1000)/1000._wp - 1._wp) < tol_wp, more = 'SD different than 1') 52 | if(allocated(error))return 53 | 54 | end subroutine 55 | 56 | 57 | end module 58 | -------------------------------------------------------------------------------- /test/test_sparse.f90: -------------------------------------------------------------------------------- 1 | program test_sparse 2 | use, intrinsic :: iso_fortran_env, only : error_unit, output_unit 3 | use testdrive, only : run_testsuite, new_testsuite, testsuite_type 4 | use modtest_coo, only : collect_coo 5 | use modtest_crs, only : collect_crs 6 | use modtest_crs64, only : collect_crs64 7 | use modtest_random, only : collect_random 8 | implicit none 9 | integer :: stat, is 10 | type(testsuite_type), allocatable :: testsuites(:) 11 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 12 | 13 | stat = 0 14 | 15 | testsuites = [ & 16 | new_testsuite("modtest_coo", collect_coo) & 17 | , new_testsuite("modtest_crs", collect_crs) & 18 | , new_testsuite("modtest_crs64", collect_crs64) & 19 | , new_testsuite("modtest_random", collect_random) & 20 | ] 21 | 22 | do is = 1, size(testsuites) 23 | write(error_unit, fmt) "Testing:", testsuites(is)%name 24 | call run_testsuite(testsuites(is)%collect, error_unit, stat, parallel = .false.) 25 | end do 26 | 27 | if (stat > 0) then 28 | write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 29 | error stop 30 | else 31 | write(output_unit, '(a)') 'All tests passed!' 32 | end if 33 | 34 | end program test_sparse 35 | -------------------------------------------------------------------------------- /test_gfortran.rsp: -------------------------------------------------------------------------------- 1 | #defaults for compiling with gfortran 2 | options test 3 | options --flag "-O3 -fall-intrinsics -I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 -L${LMETIS}" 4 | -------------------------------------------------------------------------------- /test_ifort.rsp: -------------------------------------------------------------------------------- 1 | #defaults for compiling with ifort 2 | options test 3 | options --flag "-O3 -heap-arrays -parallel -qopt-matmul -qopt-report=5 -I${MKLROOT}/include -I${MKLROOT}/include/intel64/lp64 -L${MKLROOT}/lib/intel64 -L${LMETIS}" 4 | options --compiler ifort 5 | --------------------------------------------------------------------------------