diff --git a/.gitignore b/.gitignore index 44d41ad..bd31fc7 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,6 @@ *.a *.mod make.arch - +doc/doxygen/_build +_build +_install diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..4b20676 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,36 @@ +os: linux +dist: focal + +language: python +python: 3.7 + +env: + - BUILD_SHARED_LIBS=False + - BUILD_SHARED_LIBS=True + +addons: + apt: + packages: + - cmake + - gfortran + - libblas-dev + - liblapack-dev + - libopenmpi-dev + +install: + - pip install fypp + +script: + - > + FC=gfortran cmake -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} + -DCMAKE_INSTALL_PREFIX=${PWD}/_install + -B _build . + && cmake --build _build -- -j + && cmake --install _build + - > + CMAKE_PREFIX_PATH="${PWD}/_install:${CMAKE_PREFIX_PATH}" + ./test/integration/cmake/runtest.sh _build_cmake + - > + PKG_CONFIG_PATH="${PWD}/_install/lib/pkgconfig:${PKG_CONFIG_PATH}" + FC=mpifort + ./test/integration/pkgconfig/runtest.sh _build_pkgconfig diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..86be1ec --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,65 @@ +cmake_minimum_required(VERSION 3.16) + +include(CMakePackageConfigHelpers) + +list(APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake) +include(MpiFxUtils) + +include(${CMAKE_CURRENT_SOURCE_DIR}/config.cmake) + +project(MpiFx VERSION 0.1 LANGUAGES Fortran) + +setup_build_type() + +# +# Prerequisites +# +find_package(MPI REQUIRED) +find_program(FYPP fypp) +if(NOT FYPP) + message(FATAL_ERROR "Preprocessor fypp could not be found") +endif() + +# +# Build instructions +# +include(GNUInstallDirs) + +add_subdirectory(lib) +if(NOT BUILD_EXPORTED_TARGETS_ONLY) + add_subdirectory(test) +endif() + +# +# Installation +# +add_library(MpiFx INTERFACE) +target_link_libraries(MpiFx INTERFACE mpifx) +install(TARGETS MpiFx EXPORT mpifx-targets) + +install(EXPORT mpifx-targets + FILE mpifx-targets.cmake + NAMESPACE MpiFx:: + DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/mpifx") + +configure_package_config_file( + ${CMAKE_CURRENT_SOURCE_DIR}/utils/export/mpifx-config.cmake.in + ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config.cmake + INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/mpifx) + +write_basic_package_version_file( + ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY SameMajorVersion) + +install( + FILES ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config.cmake + ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config-version.cmake + DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/mpifx) + +get_pkgconfig_params(PKGCONFIG_REQUIRES PKGCONFIG_LIBS PKGCONFIG_LIBS_PRIVATE PKGCONFIG_C_FLAGS) +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/utils/export/mpifx.pc.in + ${CMAKE_CURRENT_BINARY_DIR}/mpifx.pc @ONLY) +install( + FILES "${CMAKE_CURRENT_BINARY_DIR}/mpifx.pc" + DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig") diff --git a/LICENSE b/LICENSE index a645313..e33defa 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Bálint Aradi +Copyright (C) 2018 - 2020 DFTB+ developers group All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/README.rst b/README.rst index f3c1704..e40d884 100644 --- a/README.rst +++ b/README.rst @@ -1,12 +1,94 @@ -MPIFX - Modern Fortran Interface for MPI -======================================== +**************************************** +MpiFx - Modern Fortran Interface for MPI +**************************************** -The MPIFX project is devoted to create **modern Fortran interfaces** for -the MPI library. +The open source library `MpiFx `_ provides +modern Fortran (Fortran 2003) wrappers around routines of the MPI library to +make their use as simple as possible. Currently several data distribution +routines are covered. -It contains only a few routines for so far, but if those happen the ones -you need, feel free to use them (MPIFX is licensed under the **simplified BSD -license**). +The documentation is included inside the repository, but is also available at +`dftbplus.github.io `_. -If your routine is not wrapped yet, you could wrap it yourself and contribute it -to the project to enable to cover the target library sooner. + +Installation +============ + +Prerequisites +------------- + +* CMake (version >= 3.16) + +* Fortran 2003 compatible Fortran compiler + +* MPI-library and wrappers for your compiler + +* `Fypp preprocessor `_ + + +Building and installing the library +----------------------------------- + +The library can be built and installed with the usual CMake-workflow:: + + FC=gfortran cmake -B _build -DCMAKE_INSTALL_PREFIX=$HOME/opt/mpifx + cmake --build _build + cmake --install _build + +You can influence the configuration via CMake-variables, which are listed in +`config.cmake `_. You can either modify the values directly there +or pass them as command line options at the configuration phase, e.g.:: + + FC=ifort cmake -B _build -DBUILD_LIBRARY_ONLY=True + + +Testing +------- + +A few tests / usage examples can be found in the `test/` subdirectory. The +compiled test programs will be in the `test/` subfolder of your build directory. + + +Using the library +================= + +CMake build +----------- + +* Make sure to add the root folder of the installed library to the + ``CMAKE_PREFIX_PATH`` environment variable. + +* Use ``find_package()`` in `CMakeLists.txt` to locate the library and link + ``MpiFx::MpiFx`` to every target which relies directly on the library :: + + cmake_minimum_required(VERSION 3.16) + + project(TestMpiFx LANGUAGES Fortran) + + find_package(MpiFx REQUIRED) + + add_executable(test_mpifx test_mpifx.f90) + target_link_libraries(test_mpifx MpiFx::MpiFx) + + +Pkg-config build +---------------- + +* Make sure to add the `lib/pkgconfig` folder of the installed library to the + ``PKG_CONFIG_PATH`` environment variable. + +* Query the include and library options needed for the build with the usual + ``pkg-config`` commands:: + + mpifort $(pkg-config --cflags mpifx) test_mpifx.f90 $(pkg-config --libs mpifx) + + Note, that neither ``-cflags`` or ``--libs`` return any options related to + your MPI-framework nor is the MPI-framework specified as dependency in the + pkg-config file. Use the MPI-wrapper of your compiler to compile and link your + executable or pass the additional include and library options by hand. + + +License +======= + +MpiFx is licensed under the `2-Clause BSD License `_. diff --git a/cmake/MpiFxUtils.cmake b/cmake/MpiFxUtils.cmake new file mode 100644 index 0000000..e94f5a7 --- /dev/null +++ b/cmake/MpiFxUtils.cmake @@ -0,0 +1,58 @@ +# Register custom commands for processing source files with fypp (.fpp -> .f90) +# +# Args: +# oldfiles [in]: List of files to preprocess (must have .fpp suffix) +# newfiles [out]: List of preprocessed files (will have .f90 suffix). +# +function(fypp_preprocess oldfiles newfiles) + + set(_newfiles) + foreach(oldfile IN LISTS oldfiles) + string(REGEX REPLACE "\\.fpp" ".f90" newfile ${oldfile}) + add_custom_command( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${newfile} + COMMAND ${FYPP} ${FYPP_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/${oldfile} ${CMAKE_CURRENT_BINARY_DIR}/${newfile} + MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${oldfile}) + list(APPEND _newfiles ${CMAKE_CURRENT_BINARY_DIR}/${newfile}) + endforeach() + set(${newfiles} ${_newfiles} PARENT_SCOPE) + +endfunction() + + +# Returns the parameters needed to create a pkg-config export file +# +# Args: +# pkgconfig_requires [out]: Value for the Requires field. +# pkgconfig_libs [out]: Value for the Libs field. +# pkgconfig_libs_private [out]: Value for the Libs.private field. +# pkgconfig_c_flags [out]: Value for the cflags field. +# pkgconfig_prefix [out]: Value for the installation prefix. +# +function(get_pkgconfig_params pkgconfig_requires pkgconfig_libs pkgconfig_libs_private + pkgconfig_c_flags) + + set(_pkgconfig_requires) + + set(_pkgconfig_libs "-L${CMAKE_INSTALL_FULL_LIBDIR} -lmpifx") + + set(_pkgconfig_libs_private "${CMAKE_EXE_LINKER_FLAGS}") + + set(_pkgconfig_c_flags "-I${CMAKE_INSTALL_FULL_INCLUDEDIR}/${INSTALL_MODULEDIR}") + + set(${pkgconfig_requires} "${_pkgconfig_requires}" PARENT_SCOPE) + set(${pkgconfig_libs} "${_pkgconfig_libs}" PARENT_SCOPE) + set(${pkgconfig_libs_private} "${_pkgconfig_libs_private}" PARENT_SCOPE) + set(${pkgconfig_c_flags} "${_pkgconfig_c_flags}" PARENT_SCOPE) + +endfunction() + + +# Sets up the build type. +function (setup_build_type) + set(default_build_type "RelWithDebInfo") + if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) + message(STATUS "Setting build type to ${default_build_type} as none was specified") + set(CMAKE_BUILD_TYPE "${default_build_type}" CACHE STRING "Build type" FORCE) + endif() +endfunction() diff --git a/config.cmake b/config.cmake new file mode 100644 index 0000000..4cd2602 --- /dev/null +++ b/config.cmake @@ -0,0 +1,35 @@ +# +# Build options +# + +# CMAKE_BUILD_TYPE is commented out in order to allow for multi-configuration builds. It will +# automatically default to RelWithDebInfo if used in a single configuration build. Uncomment or +# override it only if you want a non-default single configuration build. +# +#set(CMAKE_BUILD_TYPE "Debug" CACHE STRING "Build type (Release|RelWithDebInfo|Debug|MinSizeRel)") + +# If set to True, only those public targets (typically the library) will be built, which are usually +# exported via CMake export files. Otherwise all targets all built (default case). Set this option +# to True, if you invoke this project as part of an other CMake project via the add_subdirectory() +# command without the EXCLUDE_FROM_ALL option (e.g. if you want this project to install its targets +# as part of the top projects installation process). +# +option(BUILD_EXPORTED_TARGETS_ONLY + "Whether only exported targets (the library, but no tests) should be built" FALSE) + +option(BUILD_SHARED_LIBS "Whether the library should be a shared one" FALSE) + +# +# Installation options +# + +option(INSTALL_INCLUDE_FILES "Whether include / module files should be installed" TRUE) + +set(CMAKE_INSTALL_PREFIX "${CMAKE_BINARY_DIR}/_install" CACHE STRING + "Directory to install the compiled code into") + +set(INSTALL_INCLUDEDIR "mpifx" CACHE PATH + "Installation directory for header and include files (within standard include folder)") + +set(INSTALL_MODULEDIR "${INSTALL_INCLUDEDIR}/modfiles" CACHE PATH + "Installation directory for Fortran module files (within standard include folder)") diff --git a/doc/doxygen/Doxyfile b/doc/doxygen/Doxyfile index 2c23cfb..0d08f06 100644 --- a/doc/doxygen/Doxyfile +++ b/doc/doxygen/Doxyfile @@ -241,7 +241,7 @@ OPTIMIZE_OUTPUT_VHDL = NO # that for custom extensions you also need to set FILE_PATTERNS otherwise the # files are not read by doxygen. -EXTENSION_MAPPING = +EXTENSION_MAPPING = fpp=FortranFree # If MARKDOWN_SUPPORT is enabled (the default) then doxygen pre-processes all # comments according to the Markdown format, which allows for more readable @@ -324,22 +324,6 @@ INLINE_SIMPLE_STRUCTS = NO TYPEDEF_HIDES_STRUCT = NO -# The SYMBOL_CACHE_SIZE determines the size of the internal cache use to -# determine which symbols to keep in memory and which to flush to disk. -# When the cache is full, less often used symbols will be written to disk. -# For small to medium size projects (<1000 input files) the default value is -# probably good enough. For larger projects a too small cache size can cause -# doxygen to be busy swapping symbols to and from disk most of the time -# causing a significant performance penalty. -# If the system has enough physical memory increasing the cache will improve the -# performance by keeping more symbols in memory. Note that the value works on -# a logarithmic scale so increasing the size by one will roughly double the -# memory usage. The cache size is given by this formula: -# 2^(16+SYMBOL_CACHE_SIZE). The valid range is 0..9, the default is 0, -# corresponding to a cache size of 2^16 = 65536 symbols. - -SYMBOL_CACHE_SIZE = 0 - # Similar to the SYMBOL_CACHE_SIZE the size of the symbol lookup cache can be # set using LOOKUP_CACHE_SIZE. This cache is used to resolve symbols given # their name and scope. Since this can be an expensive process and often the @@ -661,7 +645,7 @@ WARN_LOGFILE = # directories like "/usr/src/myproject". Separate the files or directories # with spaces. -INPUT = ../../src +INPUT = ../../lib # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding, which is @@ -679,7 +663,7 @@ INPUT_ENCODING = UTF-8 # *.hxx *.hpp *.h++ *.idl *.odl *.cs *.php *.php3 *.inc *.m *.mm *.dox *.py # *.f90 *.f *.for *.vhd *.vhdl -FILE_PATTERNS = *.F90 *.f90 +FILE_PATTERNS = *.fpp *.f90 # The RECURSIVE tag can be used to turn specify whether or not subdirectories # should be searched for input files as well. Possible values are YES and NO. @@ -763,13 +747,13 @@ INPUT_FILTER = # info on how filters are used. If FILTER_PATTERNS is empty or if # non of the patterns match the file name, INPUT_FILTER is applied. -FILTER_PATTERNS = *.F90=./m4f90.sh +FILTER_PATTERNS = *.fpp=./fyppf90.sh # If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using # INPUT_FILTER) will be used to filter the input files when producing source # files to browse (i.e. when SOURCE_BROWSER is set to YES). -FILTER_SOURCE_FILES = YES +#FILTER_SOURCE_FILES = YES # The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file # pattern. A pattern will override the setting for FILTER_PATTERN (if any) @@ -1410,18 +1394,6 @@ GENERATE_XML = NO XML_OUTPUT = xml -# The XML_SCHEMA tag can be used to specify an XML schema, -# which can be used by a validating XML parser to check the -# syntax of the XML files. - -XML_SCHEMA = - -# The XML_DTD tag can be used to specify an XML DTD, -# which can be used by a validating XML parser to check the -# syntax of the XML files. - -XML_DTD = - # If the XML_PROGRAMLISTING tag is set to YES Doxygen will # dump the program listings (including syntax highlighting # and cross-referencing information) to the XML output. Note that diff --git a/doc/doxygen/fyppf90.sh b/doc/doxygen/fyppf90.sh new file mode 100755 index 0000000..405b459 --- /dev/null +++ b/doc/doxygen/fyppf90.sh @@ -0,0 +1,3 @@ +#!/bin/bash +srcdir=$(dirname $1) +fypp -I$(dirname $1) $1 diff --git a/doc/doxygen/m4f90.sh b/doc/doxygen/m4f90.sh deleted file mode 100755 index 2bb9243..0000000 --- a/doc/doxygen/m4f90.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -m4 -I$(dirname $1) $1 diff --git a/doc/sphinx/Makefile b/doc/sphinx/Makefile new file mode 100644 index 0000000..a006295 --- /dev/null +++ b/doc/sphinx/Makefile @@ -0,0 +1,153 @@ +# Makefile for Sphinx documentation +# + +# You can set these variables from the command line. +SPHINXOPTS = +SPHINXBUILD = sphinx-build +PAPER = +BUILDDIR = _build + +# Internal variables. +PAPEROPT_a4 = -D latex_paper_size=a4 +PAPEROPT_letter = -D latex_paper_size=letter +ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . +# the i18n builder cannot share the environment and doctrees with the others +I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . + +.PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest gettext + +help: + @echo "Please use \`make ' where is one of" + @echo " html to make standalone HTML files" + @echo " dirhtml to make HTML files named index.html in directories" + @echo " singlehtml to make a single large HTML file" + @echo " pickle to make pickle files" + @echo " json to make JSON files" + @echo " htmlhelp to make HTML files and a HTML help project" + @echo " qthelp to make HTML files and a qthelp project" + @echo " devhelp to make HTML files and a Devhelp project" + @echo " epub to make an epub" + @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" + @echo " latexpdf to make LaTeX files and run them through pdflatex" + @echo " text to make text files" + @echo " man to make manual pages" + @echo " texinfo to make Texinfo files" + @echo " info to make Texinfo files and run them through makeinfo" + @echo " gettext to make PO message catalogs" + @echo " changes to make an overview of all changed/added/deprecated items" + @echo " linkcheck to check all external links for integrity" + @echo " doctest to run all doctests embedded in the documentation (if enabled)" + +clean: + -rm -rf $(BUILDDIR)/* + +html: + $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html + @echo + @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." + +dirhtml: + $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml + @echo + @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." + +singlehtml: + $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml + @echo + @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." + +pickle: + $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle + @echo + @echo "Build finished; now you can process the pickle files." + +json: + $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json + @echo + @echo "Build finished; now you can process the JSON files." + +htmlhelp: + $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp + @echo + @echo "Build finished; now you can run HTML Help Workshop with the" \ + ".hhp project file in $(BUILDDIR)/htmlhelp." + +qthelp: + $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp + @echo + @echo "Build finished; now you can run "qcollectiongenerator" with the" \ + ".qhcp project file in $(BUILDDIR)/qthelp, like this:" + @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/MPIFX.qhcp" + @echo "To view the help file:" + @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/MPIFX.qhc" + +devhelp: + $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp + @echo + @echo "Build finished." + @echo "To view the help file:" + @echo "# mkdir -p $$HOME/.local/share/devhelp/MPIFX" + @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/MPIFX" + @echo "# devhelp" + +epub: + $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub + @echo + @echo "Build finished. The epub file is in $(BUILDDIR)/epub." + +latex: + $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + @echo + @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." + @echo "Run \`make' in that directory to run these through (pdf)latex" \ + "(use \`make latexpdf' here to do that automatically)." + +latexpdf: + $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + @echo "Running LaTeX files through pdflatex..." + $(MAKE) -C $(BUILDDIR)/latex all-pdf + @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." + +text: + $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text + @echo + @echo "Build finished. The text files are in $(BUILDDIR)/text." + +man: + $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man + @echo + @echo "Build finished. The manual pages are in $(BUILDDIR)/man." + +texinfo: + $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + @echo + @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." + @echo "Run \`make' in that directory to run these through makeinfo" \ + "(use \`make info' here to do that automatically)." + +info: + $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + @echo "Running Texinfo files through makeinfo..." + make -C $(BUILDDIR)/texinfo info + @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." + +gettext: + $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale + @echo + @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." + +changes: + $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes + @echo + @echo "The overview file is in $(BUILDDIR)/changes." + +linkcheck: + $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck + @echo + @echo "Link check complete; look for any errors in the above output " \ + "or in $(BUILDDIR)/linkcheck/output.txt." + +doctest: + $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest + @echo "Testing of doctests in the sources finished, look at the " \ + "results in $(BUILDDIR)/doctest/output.txt." diff --git a/doc/sphinx/_themes/dftbplus/layout.html b/doc/sphinx/_themes/dftbplus/layout.html new file mode 100644 index 0000000..5bf78eb --- /dev/null +++ b/doc/sphinx/_themes/dftbplus/layout.html @@ -0,0 +1,14 @@ +{# + sphinxdoc/layout.html + ~~~~~~~~~~~~~~~~~~~~~ + + Sphinx layout template for the sphinxdoc theme. + + :copyright: Copyright 2007-2014 by the Sphinx team, see AUTHORS. + :license: BSD, see LICENSE for details. +#} +{%- extends "basic/layout.html" %} + +{# put the sidebar before the body #} +{% block sidebar1 %}{{ sidebar() }}{% endblock %} +{% block sidebar2 %}{% endblock %} diff --git a/doc/sphinx/_themes/dftbplus/static/contents.png b/doc/sphinx/_themes/dftbplus/static/contents.png new file mode 100644 index 0000000..7fb8215 Binary files /dev/null and b/doc/sphinx/_themes/dftbplus/static/contents.png differ diff --git a/doc/sphinx/_themes/dftbplus/static/dftbplus.css b/doc/sphinx/_themes/dftbplus/static/dftbplus.css new file mode 100644 index 0000000..5fecce7 --- /dev/null +++ b/doc/sphinx/_themes/dftbplus/static/dftbplus.css @@ -0,0 +1,322 @@ +/** + * DFTB+ stylesheet -- dftb+ theme + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * + * Practically the Sphinx CSS with some slight modifications + */ + +@import url("basic.css"); + +/* -- page layout ----------------------------------------------------------- */ + +body { + /*font-family: 'Lucida Grande', 'Lucida Sans Unicode', 'Geneva', + 'Verdana', sans-serif;*/ + font-family: 'Verdana', sans-serif; + font-size: 14px; + line-height: 145%; + background-color: #E6E6EB; + color: black; + padding: 0; + border: 1px solid #C8C8C8; + width: 68em; + margin: 0; +} + +div.document { + background-color: white; + text-align: left; + background-image: url(contents.png); + background-repeat: repeat-x; +} + +div.bodywrapper { +/* margin: 0 240px 0 0;*/ + border-right: 1px solid #ccc; +} + +div.body { + margin: 0; + padding: 0.5em 20px 20px 20px; +} + +div.related { + font-size: 1em; + background-color: #A4A4C8; +} + +div.related ul { + background-image: url(navigation.png); + height: 2em; + border-top: 1px solid #ddd; + border-bottom: 1px solid #ddd; +} + +div.related ul li { + margin: 0; + padding: 0; + height: 2em; + float: left; +} + +div.related ul li.right { + float: right; + margin-right: 5px; +} + +div.related ul li a { + margin: 0; + padding: 0 5px 0 5px; + line-height: 1.75em; + color: #EE9816; +} + +div.related ul li a:hover { + color: #3CA8E7; +} + +div.sphinxsidebarwrapper { + padding: 0; +} + +div.sphinxsidebar { + margin: 0; + padding: 0.5em 15px 15px 0; + width: 210px; + float: right; + font-size: 1em; + text-align: left; +} + +div.sphinxsidebar h3, div.sphinxsidebar h4 { + margin: 1em 0 0.5em 0; + font-size: 1em; + padding: 0.1em 0 0.1em 0.5em; + color: white; + border: 1px solid #86989B; + background-color: #AFC1C4; +} + +div.sphinxsidebar h3 a { + color: white; +} + +div.sphinxsidebar ul { + padding-left: 1.5em; + margin-top: 7px; + padding: 0; + line-height: 130%; +} + +div.sphinxsidebar ul ul { + margin-left: 20px; +} + +div.footer { + background-color: #E3EFF1; + color: #86989B; + padding: 3px 8px 3px 0; + clear: both; + font-size: 0.8em; + text-align: right; +} + +div.footer a { + color: #86989B; + text-decoration: underline; +} + +/* -- body styles ----------------------------------------------------------- */ + +p { + margin: 0.8em 0 0.5em 0; +} + +a { + color: #CA7900; + text-decoration: none; +} + +a:hover { + color: #2491CF; +} + +div.body a { + text-decoration: underline; +} + +h1 { + margin: 0; + padding: 0.7em 0 0.3em 0; + font-size: 1.5em; + color: #11557C; +} + +h2 { + margin: 1.3em 0 0.2em 0; + font-size: 1.35em; + padding: 0; +} + +h3 { + margin: 1em 0 -0.3em 0; + font-size: 1.2em; +} + +div.body h1 a, div.body h2 a, div.body h3 a, div.body h4 a, div.body h5 a, div.body h6 a { + color: black!important; +} + +h1 a.anchor, h2 a.anchor, h3 a.anchor, h4 a.anchor, h5 a.anchor, h6 a.anchor { + display: none; + margin: 0 0 0 0.3em; + padding: 0 0.2em 0 0.2em; + color: #aaa!important; +} + +h1:hover a.anchor, h2:hover a.anchor, h3:hover a.anchor, h4:hover a.anchor, +h5:hover a.anchor, h6:hover a.anchor { + display: inline; +} + +h1 a.anchor:hover, h2 a.anchor:hover, h3 a.anchor:hover, h4 a.anchor:hover, +h5 a.anchor:hover, h6 a.anchor:hover { + color: #777; + background-color: #eee; +} + +a.headerlink { + color: #c60f0f!important; + font-size: 1em; + margin-left: 6px; + padding: 0 4px 0 4px; + text-decoration: none!important; +} + +a.headerlink:hover { + background-color: #ccc; + color: white!important; +} + +cite, code, tt { + font-family: 'Consolas', 'Deja Vu Sans Mono', + 'Bitstream Vera Sans Mono', monospace; + font-size: 0.95em; + letter-spacing: 0.01em; +} + +tt { + background-color: #f2f2f2; + border-bottom: 1px solid #ddd; + color: #333; +} + +tt.descname, tt.descclassname, tt.xref { + border: 0; +} + +hr { + border: 1px solid #abc; + margin: 2em; +} + +a tt { + border: 0; + color: #CA7900; +} + +a tt:hover { + color: #2491CF; +} + +pre { + font-family: 'Consolas', 'Deja Vu Sans Mono', + 'Bitstream Vera Sans Mono', monospace; + font-size: 0.95em; + letter-spacing: 0.015em; + line-height: 120%; + padding: 0.5em; + border: 1px solid #ccc; + background-color: #f8f8f8; +} + +pre a { + color: inherit; + text-decoration: underline; +} + +td.linenos pre { + padding: 0.5em 0; +} + +div.quotebar { + background-color: #f8f8f8; + max-width: 250px; + float: right; + padding: 2px 7px; + border: 1px solid #ccc; +} + +div.topic { + background-color: #f8f8f8; +} + +table { + border-collapse: collapse; + margin: 0 -0.5em 0 -0.5em; +} + +table td, table th { + padding: 0.2em 0.5em 0.2em 0.5em; +} + +div.admonition, div.warning { + font-size: 0.9em; + margin: 1em 0 1em 0; + border: 1px solid #86989B; + background-color: #f7f7f7; + padding: 0; +} + +div.admonition p, div.warning p { + margin: 0.5em 1em 0.5em 1em; + padding: 0; +} + +div.admonition pre, div.warning pre { + margin: 0.4em 1em 0.4em 1em; +} + +div.admonition p.admonition-title, +div.warning p.admonition-title { + margin: 0; + padding: 0.1em 0 0.1em 0.5em; + color: white; + border-bottom: 1px solid #86989B; + font-weight: bold; + background-color: #AFC1C4; +} + +div.warning { + border: 1px solid #940000; +} + +div.warning p.admonition-title { + background-color: #CF0000; + border-bottom-color: #940000; +} + +div.admonition ul, div.admonition ol, +div.warning ul, div.warning ol { + margin: 0.1em 0.5em 0.5em 3em; + padding: 0; +} + +div.versioninfo { + margin: 1em 0 0 0; + border: 1px solid #ccc; + background-color: #DDEAF0; + padding: 8px; + line-height: 1.3em; + font-size: 0.9em; +} diff --git a/doc/sphinx/_themes/dftbplus/static/navigation.png b/doc/sphinx/_themes/dftbplus/static/navigation.png new file mode 100644 index 0000000..1081dc1 Binary files /dev/null and b/doc/sphinx/_themes/dftbplus/static/navigation.png differ diff --git a/doc/sphinx/_themes/dftbplus/static/sphinxdoc.css_t b/doc/sphinx/_themes/dftbplus/static/sphinxdoc.css_t new file mode 100644 index 0000000..47c8f89 --- /dev/null +++ b/doc/sphinx/_themes/dftbplus/static/sphinxdoc.css_t @@ -0,0 +1,356 @@ +/* + * sphinxdoc.css_t + * ~~~~~~~~~~~~~~~ + * + * Sphinx stylesheet -- sphinxdoc theme. Originally created by + * Armin Ronacher for Werkzeug. + * + * :copyright: Copyright 2007-2014 by the Sphinx team, see AUTHORS. + * :license: BSD, see LICENSE for details. + * + * Some modifications for the + */ + +@import url("basic.css"); + +/* -- page layout ----------------------------------------------------------- */ + +body { + font-family: 'Lucida Grande', 'Lucida Sans Unicode', 'Geneva', + 'Verdana', sans-serif; + font-size: 14px; + letter-spacing: -0.01em; + line-height: 150%; + text-align: center; + background-color: #E6E6EB; + color: black; + padding: 0; + border: 1px solid #C8C8C8; + margin: 0px 2em 0px 0em; + width: 65em; +} + +div.document { + background-color: white; + text-align: justify; + background-image: url(contents.png); + background-repeat: repeat-x; +} + +div.bodywrapper { + margin: 0 {{ theme_sidebarwidth|toint + 10 }}px 0 0; + border-right: 1px solid #ccc; +} + +div.body { + margin: 0; + padding: 0.5em 3em 20px 3em; +} + +div.related { + font-size: 1em; +} + +div.related ul { + background-image: url(navigation.png); + height: 2em; + border-top: 1px solid #ddd; + border-bottom: 1px solid #ddd; +} + +div.related ul li { + margin: 0; + padding: 0; + height: 2em; + float: left; +} + +div.related ul li.right { + float: right; + margin-right: 5px; +} + +div.related ul li a { + margin: 0; + padding: 0 5px 0 5px; + line-height: 1.75em; + color: #EE9816; +} + +div.related ul li a:hover { + color: #3CA8E7; +} + +div.sphinxsidebarwrapper { + padding: 0; +} + +div.sphinxsidebar { + margin: 0; + padding: 0.5em 15px 15px 0; + width: {{ theme_sidebarwidth|toint - 20 }}px; + float: right; + font-size: 1em; + text-align: left; +} + +div.sphinxsidebar h3, div.sphinxsidebar h4 { + margin: 1em 0 0.5em 0; + font-size: 1em; + padding: 0.1em 0 0.1em 0.5em; + color: #555; + border: 1px solid #86989B; + background-color: #E6E6EB; /* #AFC1C4; */ +} + +div.sphinxsidebar h3 a { + color: #555; +} + +div.sphinxsidebar ul { + padding-left: 1.5em; + margin-top: 7px; + padding: 0; + line-height: 130%; +} + +div.sphinxsidebar ul ul { + margin-left: 20px; +} + +div.footer { + background-color: #E3EFF1; + color: #86989B; + padding: 3px 8px 3px 0; + clear: both; + font-size: 0.8em; + text-align: right; +} + +div.footer a { + color: #86989B; + text-decoration: underline; +} + +/* -- body styles ----------------------------------------------------------- */ + +p { + margin: 0.8em 0 0.5em 0; +} + +a { + color: #CA7900; + text-decoration: none; +} + +a:hover { + color: #2491CF; +} + +div.body a { + text-decoration: none; +} + +h1 { + margin: 0; + padding: 1.7em 0 0.3em 0; + font-size: 1.7em; + color: #11557C; + text-align: left; +} + +h2 { + margin: 1.4em 0 0.2em 0; + font-size: 1.4em; + padding: 0; + text-align: left; +} + +h3 { + margin: 1.2em 0 -0.3em 0; + font-size: 1.2em; + text-align: left; +} + +h4 { + margin: 1em 0 -0.3em 0; + font-size: 1em; + text-align: left; +} + +div.body h1 a, div.body h2 a, div.body h3 a, div.body h4 a, div.body h5 a, div.body h6 a { + color: black!important; +} + +h1 a.anchor, h2 a.anchor, h3 a.anchor, h4 a.anchor, h5 a.anchor, h6 a.anchor { + display: none; + margin: 0 0 0 0.3em; + padding: 0 0.2em 0 0.2em; + color: #aaa!important; +} + +h1:hover a.anchor, h2:hover a.anchor, h3:hover a.anchor, h4:hover a.anchor, +h5:hover a.anchor, h6:hover a.anchor { + display: inline; +} + +h1 a.anchor:hover, h2 a.anchor:hover, h3 a.anchor:hover, h4 a.anchor:hover, +h5 a.anchor:hover, h6 a.anchor:hover { + color: #777; + background-color: #eee; +} + +a.headerlink { + color: #c60f0f!important; + font-size: 1em; + margin-left: 6px; + padding: 0 4px 0 4px; + text-decoration: none!important; +} + +a.headerlink:hover { + background-color: #ccc; + color: white!important; +} + +cite, code, tt { + font-family: 'Consolas', 'Deja Vu Sans Mono', + 'Bitstream Vera Sans Mono', monospace; + font-size: 1em; + letter-spacing: 0.01em; +} + +cite { + /* font-weight: bold; */ + font-style: normal; /* italic; */ + color: #11557C +} + +tt { + /* background-color: #f2f2f2; */ + /* border-bottom: 1px solid #ddd; */ + color: #222; + font-size: 0.96em; + font-weight: bold; +} + +tt.descname, tt.descclassname, tt.xref { + border: 0; +} + +hr { + border: 1px solid #abc; + margin: 2em; +} + +a tt { + border: 0; + color: #CA7900; +} + +a tt:hover { + color: #2491CF; +} + +pre { + font-family: 'Consolas', 'Deja Vu Sans Mono', + 'Bitstream Vera Sans Mono', monospace; + font-size: 0.95em; + letter-spacing: 0.015em; + line-height: 120%; + padding: 0.5em; + border: 1px solid #ccc; + background-color: #f7ffe3; +} + +pre a { + color: inherit; + text-decoration: underline; +} + +td.linenos pre { + padding: 0.5em 0; +} + +div.quotebar { + background-color: #f8f8f8; + max-width: 250px; + float: right; + padding: 2px 7px; + border: 1px solid #ccc; +} + +div.topic { + background-color: #f8f8f8; +} + +table { + border-collapse: collapse; + margin: 0 -0.5em 0 -0.5em; +} + +table td, table th { + padding: 0.2em 0.5em 0.2em 0.5em; +} + +div.admonition, div.warning { + font-size: 0.9em; + margin: 1em 0 1em 0; + border: 1px solid #86989B; + background-color: #f7f7f7; + padding: 0; +} + +div.admonition p, div.warning p { + margin: 0.5em 1em 0.5em 1em; + padding: 0; +} + +div.admonition pre, div.warning pre { + margin: 0.4em 1em 0.4em 1em; +} + +div.admonition p.admonition-title, +div.warning p.admonition-title { + margin: 0; + padding: 0.1em 0 0.1em 0.5em; + color: white; + border-bottom: 1px solid #86989B; + font-weight: bold; + background-color: #AFC1C4; +} + +div.warning { + border: 1px solid #940000; +} + +div.warning p.admonition-title { + background-color: #CF0000; + border-bottom-color: #940000; +} + +div.admonition ul, div.admonition ol, +div.warning ul, div.warning ol { + margin: 0.1em 0.5em 0.5em 3em; + padding: 0; +} + +div.versioninfo { + margin: 1em 0 0 0; + border: 1px solid #ccc; + background-color: #DDEAF0; + padding: 8px; + line-height: 1.3em; + font-size: 0.9em; +} + +.viewcode-back { + font-family: 'Lucida Grande', 'Lucida Sans Unicode', 'Geneva', + 'Verdana', sans-serif; +} + +div.viewcode-block:target { + background-color: #f4debf; + border-top: 1px solid #ac9; + border-bottom: 1px solid #ac9; +} diff --git a/doc/sphinx/_themes/dftbplus/theme.conf b/doc/sphinx/_themes/dftbplus/theme.conf new file mode 100644 index 0000000..9a22fef --- /dev/null +++ b/doc/sphinx/_themes/dftbplus/theme.conf @@ -0,0 +1,4 @@ +[theme] +inherit = basic +stylesheet = sphinxdoc.css +pygments_style = friendly diff --git a/doc/sphinx/about.rst b/doc/sphinx/about.rst new file mode 100644 index 0000000..4feff63 --- /dev/null +++ b/doc/sphinx/about.rst @@ -0,0 +1,41 @@ +About MPIFX +=========== + +`MPIFX `_ is a library containing modern +Fortran (Fortran 2003) wrappers around MPI routines. The goal is to make the use +of MPI as simple as possible in Fortran. + +Consider for example a simple MPI broadcast. In order to broadcast an integer +array with 25 elements using the legacy MPI routine, you have to issue:: + + call mpi_bcast(myarray, 25, MPI_INTEGER, 0, MPI_COMM_WORLD, error) + +Additional to the object to be broadcasted and the communicator, you also +*must* specify following arguments: + +- type of the array (which is redundant, as it is *known* at compile-time) + +- size of the array (which is redundant, as it is *known* at run-time) + +- root node of the broadcast (setting it to the lead node as default would + be a definitely safe choice) + +- error flag (one could per default just omit it and rely on the program to stop + if a problem arised, similar as done in Fortran for allocations) + +Using MPIFX the call above is as simple as:: + + call mpifx_bcast(comm, myarray) + +No redundant arguments, sensible defaults. Nevertheless the full functionality +is still available via optional parameters if needed. E.g. if you wanted to +handle the error flag yourself (making sure an error won't stop your code), you +could call:: + + call mpifx_bcast(comm, myarray, error=ierr) + +A few essential communication routines are already covered (see +:ref:`sec_routines`). If your desired MPI-routine is not among them yet, you are +cordially invited to extend MPIFX and to share it in order to let others profit +from your work (MPIFX is licensed under the simplified BSD license). For more +details see the `project page `_. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py new file mode 100644 index 0000000..cb0fdd9 --- /dev/null +++ b/doc/sphinx/conf.py @@ -0,0 +1,249 @@ +# -*- coding: utf-8 -*- +# +# This file is execfile()d with the current directory set to its containing dir. +# +# Note that not all possible configuration values are present in this +# autogenerated file. +# +# All configuration values have a default; values that are commented out +# serve to show the default. + +import sys, os + +# If extensions (or modules to document with autodoc) are in another directory, +# add these directories to sys.path here. If the directory is relative to the +# documentation root, use os.path.abspath to make it absolute, like shown here. +#sys.path.insert(0, os.path.abspath('.')) + +# -- General configuration ----------------------------------------------------- + +# If your documentation needs a minimal Sphinx version, state it here. +#needs_sphinx = '1.0' + +# Add any Sphinx extension module names here, as strings. They can be extensions +# coming with Sphinx (named 'sphinx.ext.*') or your custom ones. +extensions = [] + +# Add any paths that contain templates here, relative to this directory. +templates_path = ['_templates'] + +# The suffix of source filenames. +source_suffix = '.rst' + +# The encoding of source files. +#source_encoding = 'utf-8-sig' + +# The master toctree document. +master_doc = 'index' + +# General information about the project. +project = u'MPIFX' +copyright = u'2013, B. Aradi' + +# The version info for the project you're documenting, acts as replacement for +# |version| and |release|, also used in various other places throughout the +# built documents. +# +# The short X.Y version. +version = '12.12' + +# The full version, including alpha/beta/rc tags. +release = '12.12' + +# The language for content autogenerated by Sphinx. Refer to documentation +# for a list of supported languages. +#language = None + +# There are two options for replacing |today|: either, you set today to some +# non-false value, then it is used: +#today = '' +# Else, today_fmt is used as the format for a strftime call. +#today_fmt = '%B %d, %Y' + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +exclude_patterns = ['_build'] + +# The reST default role (used for this markup: `text`) to use for all documents. +#default_role = None + +# If true, '()' will be appended to :func: etc. cross-reference text. +#add_function_parentheses = True + +# If true, the current module name will be prepended to all description +# unit titles (such as .. function::). +#add_module_names = True + +# If true, sectionauthor and moduleauthor directives will be shown in the +# output. They are ignored by default. +#show_authors = False + +# The name of the Pygments (syntax highlighting) style to use. +pygments_style = 'sphinx' + +# A list of ignored prefixes for module index sorting. +#modindex_common_prefix = [] + + +# -- Options for HTML output --------------------------------------------------- + +# The theme to use for HTML and HTML Help pages. See the documentation for +# a list of builtin themes. +html_theme = 'dftbplus' + +# Theme options are theme-specific and customize the look and feel of a theme +# further. For a list of options available for each theme, see the +# documentation. +html_theme_options = { + #"rightsidebar": "true", + #"nosidebar": "true", + } + +# Add any paths that contain custom themes here, relative to this directory. +html_theme_path = [ "_themes" ] + +# The name for this set of Sphinx documents. If None, it defaults to +# " v documentation". +html_title = "MPIFX" + +# A shorter title for the navigation bar. Default is the same as html_title. +#html_short_title = None + +# The name of an image file (relative to this directory) to place at the top +# of the sidebar. +#html_logo = None + +# The name of an image file (within the static path) to use as favicon of the +# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 +# pixels large. +#html_favicon = None + +# Add any paths that contain custom static files (such as style sheets) here, +# relative to this directory. They are copied after the builtin static files, +# so a file named "default.css" will overwrite the builtin "default.css". +html_static_path = ['_static'] + +# If not '', a 'Last updated on:' timestamp is inserted at every page bottom, +# using the given strftime format. +#html_last_updated_fmt = '%b %d, %Y' + +# If true, SmartyPants will be used to convert quotes and dashes to +# typographically correct entities. +#html_use_smartypants = True + +# Custom sidebar templates, maps document names to template names. +html_sidebars = { + '**': [ "relations.html", "globaltoc.html" ], +} + +# Additional templates that should be rendered to pages, maps page names to +# template names. +#html_additional_pages = {} + +# If false, no module index is generated. +#html_domain_indices = True + +# If false, no index is generated. +html_use_index = False + +# If true, the index is split into individual pages for each letter. +#html_split_index = False + +# If true, links to the reST sources are added to the pages. +#html_show_sourcelink = True + +# If true, "Created using Sphinx" is shown in the HTML footer. Default is True. +#html_show_sphinx = True + +# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. +html_show_copyright = False + +# If true, an OpenSearch description file will be output, and all pages will +# contain a tag referring to it. The value of this option must be the +# base URL from which the finished HTML is served. +#html_use_opensearch = '' + +# This is the file name suffix for HTML files (e.g. ".xhtml"). +#html_file_suffix = None + +# Output file base name for HTML help builder. +htmlhelp_basename = 'MPIFXdoc' + + +# -- Options for LaTeX output -------------------------------------------------- + +latex_elements = { +# The paper size ('letterpaper' or 'a4paper'). +#'papersize': 'letterpaper', + +# The font size ('10pt', '11pt' or '12pt'). +#'pointsize': '10pt', + +# Additional stuff for the LaTeX preamble. +#'preamble': '', +} + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, author, documentclass [howto/manual]). +latex_documents = [ + ('index', 'mpifx.tex', u'MPIFX', + u'B. Aradi', 'manual'), +] + +# The name of an image file (relative to this directory) to place at the top of +# the title page. +#latex_logo = None + +# For "manual" documents, if this is true, then toplevel headings are parts, +# not chapters. +#latex_use_parts = False + +# If true, show page references after internal links. +latex_show_pagerefs = True +latex_elements = { 'papersize': 'a4paper', # a4 + 'pointsize': '10pt', # script size + 'fncychap': '\\usepackage[Lenny]{fncychap}', + } + +# If true, show URL addresses after external links. +#latex_show_urls = False + +# Documents to append as an appendix to all manuals. +#latex_appendices = [] + +# If false, no module index is generated. +#latex_domain_indices = True + + +# -- Options for manual page output -------------------------------------------- + +# One entry per manual page. List of tuples +# (source start file, name, description, authors, manual section). +man_pages = [ + ('index', 'MPIFX', u'MPIFX Documentation', + [u'B. Aradi'], 1) +] + +# If true, show URL addresses after external links. +#man_show_urls = False + + +# -- Options for Texinfo output ------------------------------------------------ + +# Grouping the document tree into Texinfo files. List of tuples +# (source start file, target name, title, author, +# dir menu entry, description, category) +texinfo_documents = [ + ('index', 'MPIFX', u'MPIFX Documentation', + u'B. Aradi', 'MPIFX', 'One line description of project.', + 'Miscellaneous'), +] + +# Documents to append as an appendix to all manuals. +#texinfo_appendices = [] + +# If false, no module index is generated. +#texinfo_domain_indices = True + +# How to display URL addresses: 'footnote', 'no', or 'inline'. +#texinfo_show_urls = 'footnote' diff --git a/doc/sphinx/index.rst b/doc/sphinx/index.rst new file mode 100644 index 0000000..7b7495f --- /dev/null +++ b/doc/sphinx/index.rst @@ -0,0 +1,12 @@ +Welcome to MPIFX's documentation! +================================= + +.. toctree:: + :maxdepth: 1 + + about.rst + installing.rst + using.rst + routines.rst + license.rst + diff --git a/doc/sphinx/installing.rst b/doc/sphinx/installing.rst new file mode 100644 index 0000000..7cf8e90 --- /dev/null +++ b/doc/sphinx/installing.rst @@ -0,0 +1,79 @@ +Compiling and installing MPIFX +============================== + +In order to compile MPIFX, you need following prerequisites: + +* Fortran 2003 compiler, + +* Python (2.6, 2.7 or any 3.x release) + +* GNU Make. + +There are basically two different ways of using the library in your project: + +* `Precompiling the library`_ and linking it later to your project. + +* `Compiling the library during your build process`_. + +Both are described below. + + +Precompiling the library +************************ + +In order to create a precompiled library + +#. Copy the file `make.arch.template` to `make.arch` in the root directory of + the source and customize the settings for the compilers and the linker + according to your system. + +#. Issue `make` to build the library. + +#. Issue `make install` to copy the library and the module files to the + installation destination. + +During the build process of your project, you may link the library with the +`-lmpifx` option. Eventually, you may need to specify options for your compiler +and your linker to specify the location of those directories. Assuming you've +put the module files in the directory `` and the library file in +``, you would typically invoke your compiler for the source files +using the `libmpifx_module` as:: + + F2003_COMPILER -I -c somesource.f90 + +and link your object files at the end with:: + + LINKER -I somesource.o ... -L -lmpifx + + +Compiling the library during your build process +*********************************************** + +In order to build the library during the build process of your project: + +#. Copy the content of the `lib/` folder into a *separate* folder within your + project. + +#. During the make process of your project, invoke the library makefile + (`make.build`) to build the module files and the library in the folder + where you've put the library sources. + + You must pass the compiler and linker options via variable defintions at the + make command line. Assuming that the variables `$(FXX)`, `$(FXXOPT)`, `$(LN)` + and `$(LNOPT)`, `$(FYPP)` and `$(FYPPOPT)` contain the Fortran compiler, the + Fortran compiler options, the linker, the linker options, the Fypp + preprocessor and its options, respectively, you would have something like:: + + libmpifx.a: + $(MAKE) -C $(MPIFX_BUILDDIR) \ + FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ + LN="$(LN)" LNOPT="$(LNOPT)" \ + FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" \ + -f $(MPIFX_SRCDIR)/make.build + + in the makefile of your project with `$(MPIFX_SRCDIR)` being the directory + where you've put the source of MPIFX and `$(MPIFX_BUILDDIR)` where the build + of the library should be done. + +You should also have a look at the `Umakefile` in the root folder of MPIFX, +which uses exactly the same technique to compile the library. diff --git a/doc/sphinx/license.rst b/doc/sphinx/license.rst new file mode 100644 index 0000000..82258d1 --- /dev/null +++ b/doc/sphinx/license.rst @@ -0,0 +1,29 @@ +License +======= + +MPIFX is licensed under the simplified BSD license:: + + Copyright (c) 2018, Bálint Aradi + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/doc/sphinx/routines.rst b/doc/sphinx/routines.rst new file mode 100644 index 0000000..a4eda1c --- /dev/null +++ b/doc/sphinx/routines.rst @@ -0,0 +1,7 @@ +.. _sec_routines: + +List of routines +================ + +You can generate the list and the description of the MPIFX routines via doxygen +(see folder `doc/doxygen/` in the source tree). diff --git a/doc/sphinx/using.rst b/doc/sphinx/using.rst new file mode 100644 index 0000000..35c0a65 --- /dev/null +++ b/doc/sphinx/using.rst @@ -0,0 +1,73 @@ +Using MPIFX +=========== + +Before you can use the MPIFX routines you need the following steps: + +#. Use the module `libmpifx_module` in your routines. + +#. Initialize the MPI framework via the `mpifx_init()` routine. (If you already + initialized it via the legacy `mpi_init()` call, you should omit this step. + +#. Initialize a communicator of `type(mpifx_comm)`. + +Below you find a self containing example for reduction on all processes using +a wrapper around `mpi_allreduce()`:: + + program test_allreduce + use libmpifx_module + implicit none + + integer, parameter :: dp = kind(1.0d0) + + type(mpifx_comm) :: mycomm + integer :: vali0, resvali0 + real(dp) :: valr(3), resvalr(3) + + call mpifx_init() + call mycomm%init() + + ! Reduce scalar value + vali0 = mycomm%rank * 2 ! Some arbitrary number + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%rank, & + & "Value to be operated on:", vali0 + call mpifx_allreduce(mycomm, vali0, resvali0, MPI_SUM) + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%rank, & + & "Obtained result (sum):", resvali0 + + ! Reduce vector + valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + & "Value to be operated on:", valr(:) + call mpifx_allreduce(mycomm, valr, resvalr, MPI_PROD) + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + & "Obtained result (prod):", resvalr(:) + call mpifx_finalize() + + end program test_allreduce + + +When running on 4 processors:: + + mpirun -n 4 test_allreduce | sort + +you should obtain the following output:: + + 01-000| Value to be operated on:0 + 01-001| Value to be operated on:2 + 01-002| Value to be operated on:4 + 01-003| Value to be operated on:6 + 02-000| Obtained result (sum):12 + 02-001| Obtained result (sum):12 + 02-002| Obtained result (sum):12 + 02-003| Obtained result (sum):12 + 03-000| Value to be operated on: 1.20 4.30 3.80 + 03-001| Value to be operated on: 2.40 8.60 7.60 + 03-002| Value to be operated on: 3.60 12.90 11.40 + 03-003| Value to be operated on: 4.80 17.20 15.20 + 04-000| Obtained result (prod): 49.77 8205.12 5004.33 + 04-001| Obtained result (prod): 49.77 8205.12 5004.33 + 04-002| Obtained result (prod): 49.77 8205.12 5004.33 + 04-003| Obtained result (prod): 49.77 8205.12 5004.33 + +Have a look at the test folder in the source tree for further examples. diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt new file mode 100644 index 0000000..8fd9245 --- /dev/null +++ b/lib/CMakeLists.txt @@ -0,0 +1,50 @@ +set(sources-fpp + module.fpp + mpifx_abort.fpp + mpifx_allgather.fpp + mpifx_allgatherv.fpp + mpifx_allreduce.fpp + mpifx_barrier.fpp + mpifx_bcast.fpp + mpifx_comm.fpp + mpifx_common.fpp + mpifx_constants.fpp + mpifx_finalize.fpp + mpifx_gather.fpp + mpifx_gatherv.fpp + mpifx_get_processor_name.fpp + mpifx_helper.fpp + mpifx_init.fpp + mpifx_recv.fpp + mpifx_reduce.fpp + mpifx_scatter.fpp + mpifx_scatterv.fpp + mpifx_send.fpp) + +fypp_preprocess("${sources-fpp}" sources-f90) + +# NAG compiler won't compile these files without the '-mismatch' option +if("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "NAG") + set_source_files_properties(SOURCE ${sources-f90} PROPERTY COMPILE_FLAGS -mismatch) +endif() + +add_library(mpifx ${sources-f90}) + +target_link_libraries(mpifx PRIVATE MPI::MPI_Fortran) + +set(BUILD_MOD_DIR ${CMAKE_CURRENT_BINARY_DIR}/include) + +set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${BUILD_MOD_DIR}) + +target_include_directories(mpifx PUBLIC + $ + $) + +install(TARGETS mpifx + EXPORT mpifx-targets + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) + +if(INSTALL_INCLUDE_FILES) + install(DIRECTORY ${BUILD_MOD_DIR}/ DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/${INSTALL_MODULEDIR}) +endif() diff --git a/lib/module.fpp b/lib/module.fpp new file mode 100644 index 0000000..a121129 --- /dev/null +++ b/lib/module.fpp @@ -0,0 +1,36 @@ +!> \mainpage Modern Fortran wrappers around MPI routines +!! +!! The open source library [MPIFX](https://github.com/dftbplus/mpifx) is +!! an effort to provide modern Fortran (Fortran 2003) wrappers around +!! routines of the MPI library to make their use as simple as possible. +!! +!! For more information see the following sources: +!! * [Online documentation](https://github.com/dftbplus/mpifx) +!! for installation and usage of the library +!! * [API documentation](annotated.html) for the reference manual. +!! * [Project home page](https://github.com/dftbplus/mpifx) +!! for the source code, bug tracker and further information on the project. +!! +module libmpifx_module + use mpifx_constants_module + use mpifx_comm_module + use mpifx_abort_module + use mpifx_get_processor_name_module + use mpifx_barrier_module + use mpifx_bcast_module + use mpifx_finalize_module + use mpifx_init_module + use mpifx_send_module + use mpifx_recv_module + use mpifx_reduce_module + use mpifx_allreduce_module + use mpifx_gather_module + use mpifx_gatherv_module + use mpifx_allgather_module + use mpifx_allgatherv_module + use mpifx_scatter_module + use mpifx_scatterv_module + implicit none + public + +end module libmpifx_module diff --git a/lib/mpifx.fypp b/lib/mpifx.fypp new file mode 100644 index 0000000..68e76bb --- /dev/null +++ b/lib/mpifx.fypp @@ -0,0 +1,124 @@ +#:mute + +#! Set DEBUG to 0 unless DEBUG level is specified explicitely +#:set DEBUG = getvar('DEBUG', 0) + +#! Build normal library unless stub library is explicitly requested +#!#:set STUB_LIBRARY = defined('STUB_LIBRARY') + +#:set INT_TYPES = ['int'] + +#:set FLOAT_TYPES = ['real', 'dreal', 'complex', 'dcomplex'] + +#:set LOGICAL_TYPES = ['logical'] + +#:set CHAR_TYPES = ['char'] + +#:set NUMERIC_TYPES = INT_TYPES + FLOAT_TYPES + +#:set ALL_TYPES = NUMERIC_TYPES + LOGICAL_TYPES + CHAR_TYPES + +#:set TYPE_ABBREVS = {'int': 'i', 'real': 's', 'dreal': 'd', 'complex': 'c', 'dcomplex': 'z',& + & 'logical': 'l', 'char': 'h'} + +#! Fortran types +#:set FORTRAN_TYPES = {'int': 'integer', 'real': 'real(sp)', 'dreal': 'real(dp)',& + & 'complex': 'complex(sp)', 'dcomplex': 'complex(dp)', 'logical': 'logical',& + & 'char': 'character(len=*)'} + +#! Corresponding MPI types +#:set MPI_TYPES = {'int': 'MPI_INTEGER', 'real': 'MPI_REAL', 'dreal': 'MPI_DOUBLE_PRECISION',& + & 'complex': 'MPI_COMPLEX', 'dcomplex': 'MPI_DOUBLE_COMPLEX', 'logical': 'MPI_LOGICAL', & + & 'char': 'MPI_CHARACTER'} + +#! Whether length must be taken into account, if count is calculated +#:set HAS_LENGTH = {'int': False, 'real': False, 'dreal': False, 'complex': False,& + &'dcomplex': False, 'logical': False, 'char': True} + +#! Maximal rank covered in the wrappers +#:set MAX_RANK = getvar('MAX_RANK', 6) + + +#! Returns colons within paranthesis according to the RANK or empty string +#! if RANK is zero. +#:def RANKSUFFIX(RANK) +${'' if RANK == 0 else '(' + ':' + ',:' * (RANK - 1) +')'}$ +#:enddef RANKSUFFIX + + +#! Indicates debug code. +#! +#! code: Code to insert, if DEBUG > 0 +#! +#:def DEBUG_CODE(code) +#:if DEBUG > 0 +$:code +#:endif +#:enddef DEBUG_CODE + + +#! Asserts the validity of a condition. +#! +#! cond: Condition +#! +#:def ASSERT(COND) +#:call DEBUG_CODE +if (.not. (${COND}$)) then + call assert_failed("${_FILE_}$", ${_LINE_}$) +end if +#:endcall +#:enddef ASSERT + + +#! Sets an optional output argument (aa) if present to a certain value (bb). +#! +#:def handle_outoptflag(aa, bb) + if (present(${aa}$)) then + ${aa}$ = ${bb}$ + end if +#:enddef + + +#! Allocates an array (aa) to a minimal size (bb) with an actual size +#! stored in (cc). If the optional allocatable argument (dd) is present +#! and big enough, its allocation transfer will be transfered instead of +#! a new allocation. +#! +#:def move_minoptalloc(aa, bb, cc, dd) + if (present(${dd}$)) then + if (size(${dd}$) >= ${bb}$) then + call move_alloc(${dd}$, ${aa}$) + else + deallocate(${dd}$) + end if + end if + if (.not. allocated(${aa}$)) then + allocate(${aa}$(${bb}$)) + end if + ${cc}$ = size(${aa}$) +#:enddef move_minoptalloc + + +#! Sets a variable (aa) to the value of an optional argument (bb) +#! if present or to a default value (cc) otherwise. +#! +#:def inoptflags(aa,bb,cc) + if (present(${bb}$)) then + ${aa}$ = ${bb}$ + else + ${aa}$ = ${cc}$ + end if +#:enddef + + + +#! Sets an optional output argument (aa) if present to a certain value (bb). +#! +#:def handle_outoptflag(aa, bb) + if (present(${aa}$)) then + ${aa}$ = ${bb}$ + end if +#:enddef + + +#:endmute diff --git a/lib/mpifx_abort.fpp b/lib/mpifx_abort.fpp new file mode 100644 index 0000000..0d7203f --- /dev/null +++ b/lib/mpifx_abort.fpp @@ -0,0 +1,53 @@ +!> Contains wrapper for \c MPI_ABORT. +module mpifx_abort_module + use mpifx_common_module + implicit none + private + + public :: mpifx_abort + +contains + + !> Aborts MPI processes for the given communicator. + !! + !! \param mycomm MPI handler. + !! \param errorcode Exit error code for the operating system. (default: 1) + !! \param error Optional error flag. + !! + !! \see MPI documentation (\c MPI_ABORT) + !! + !! Example: + !! + !! program test_abort + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! + !! call mpifx_init() + !! call mycomm%init() + !! : + !! ! Stoping the program (e.g. due to error we can not handle) + !! call mpifx_abort(mycomm, 2) + !! + !! end program test_abort + !! + subroutine mpifx_abort(mycomm, errorcode, error) + type(mpifx_comm), intent(in) :: mycomm + integer, intent(in), optional :: errorcode + integer, intent(out), optional :: error + + integer :: error0, errorcode0 + + if (present(errorcode)) then + errorcode0 = errorcode + else + errorcode0 = -1 + end if + + call mpi_abort(mycomm%id, errorcode0, error0) + call handle_errorflag(error0, "MPI_ABORT in mpifx_abort", error) + + end subroutine mpifx_abort + +end module mpifx_abort_module diff --git a/lib/mpifx_allgather.fpp b/lib/mpifx_allgather.fpp new file mode 100644 index 0000000..893d2fa --- /dev/null +++ b/lib/mpifx_allgather.fpp @@ -0,0 +1,191 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(MAX_RANK + 1) + +!> Contains wrapper for \c MPI_ALLGATHER +module mpifx_allgather_module + use mpifx_common_module + implicit none + private + + public :: mpifx_allgather + + !> Gathers scalars/arrays on all nodes. + !! + !! All functions have the same argument list only differing in the type and + !! rank of the second and third arguments. The second and third arguments can + !! be of type integer, real, double precision, complex, double complex and + !! logical. Their rank can vary from zero (scalars) up to the maximum + !! rank. Both arguments must be of same type. The third argument must have the + !! size of the second times the number of processes taking part in the + !! gathering. The third argument must have either the same rank as the second + !! one or one rank more. In latter case its last dimension must be of the size + !! of the number of processes participating in the gathering operation. + !! + !! See MPI documentation (mpi_allgather()) for further details. + !! + !! Example: + !! + !! program test_gather + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! integer :: send0 + !! integer, allocatable :: send1(:) + !! integer, allocatable :: recv1(:), recv2(:,:) + !! character(100) :: formstr + !! character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + !! + !! call mpifx_init() + !! call mycomm%init() + !! + !! ! I0 -> I1 + !! send0 = mycomm%rank * 2 + !! allocate(recv1(1 * mycomm%size)) + !! recv1(:) = 0 + !! write(*, *) mycomm%rank, "Send0 buffer:", send0 + !! call mpifx_gather(mycomm, send0, recv1) + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1(:) + !! deallocate(recv1) + !! + !! ! I1 -> I1 + !! allocate(send1(2)) + !! allocate(recv1(size(send1) * mycomm%size)) + !! recv1(:) = 0 + !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + !! write(*, *) "Send1 buffer:", send1(:) + !! call mpifx_gather(mycomm, send1, recv1) + !! write(*, *) "Recv1 buffer:", recv1 + !! + !! ! I1 -> I2 + !! allocate(recv2(size(send1), mycomm%size)) + !! recv2(:,:) = 0 + !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + !! write(*, *) "Send1 buffer:", send1(:) + !! call mpifx_gather(mycomm, send1, recv2) + !! write(*, *) "Recv2 buffer:", recv2 + !! + !! call mpifx_finalize() + !! + !! end program test_gather + !! + interface mpifx_allgather +#:for TYPE in TYPES + #:for RANK in RANKS + #:set TYPEABBREV = TYPE_ABBREVS[TYPE] + + #:if RANK > 0 + module procedure mpifx_allgather_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK}$ + #:endif + + #:if RANK < MAX_RANK + module procedure mpifx_allgather_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK + 1}$ + #:endif + + #:endfor +#:endfor + end interface mpifx_allgather + +contains + + +#:def mpifx_allgather_dr0_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK > 0 + + !> Gathers results on all processes (type ${SUFFIX}$). + !! + !! See mpi_allgather() for further details. + !! + subroutine mpifx_allgather_${SUFFIX}$(mycomm, send, recv, error) + + !> MPI communicator. + type(mpifx_comm), intent(in) :: mycomm + + !> Quantity to be sent for gathering. + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + + !> Received data. + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ + + !> Error code on exit. + integer, intent(out), optional :: error + + integer :: error0 + + #:set SIZE = 'size(send)' + #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(size(recv) == ${SIZE}$ * mycomm%size) + @:ASSERT(size(recv, dim=${RANK}$) == size(send, dim=${RANK}$) * mycomm%size) + + call mpi_allgather(send, ${COUNT}$, ${MPITYPE}$, recv, ${COUNT}$, ${MPITYPE}$, mycomm%id,& + & error0) + call handle_errorflag(error0, 'MPI_ALLGATHER in mpifx_allgather_${SUFFIX}$', error) + + end subroutine mpifx_allgather_${SUFFIX}$ + +#:enddef mpifx_allgather_dr0_template + + +#:def mpifx_allgather_dr1_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK >= 0 + + !> Gathers results on all processes (type ${SUFFIX}$). + !! + !! See mpi_allgather() for further details. + !! + subroutine mpifx_allgather_${SUFFIX}$(mycomm, send, recv, error) + + !> MPI communicator. + type(mpifx_comm), intent(in) :: mycomm + + !> Quantity to be sent for gathering. + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + + !> Received data. + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK + 1)}$ + + !> Error code on exit. + integer, intent(out), optional :: error + + integer :: error0 + + #:set SIZE = '1' if RANK == 0 else 'size(send)' + #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(size(recv) == ${SIZE}$ * mycomm%size) + @:ASSERT(size(recv, dim=${RANK + 1}$) == mycomm%size) + + call mpi_allgather(send, ${COUNT}$, ${MPITYPE}$, recv, ${COUNT}$, ${MPITYPE}$,& + & mycomm%id, error0) + call handle_errorflag(error0, 'MPI_ALLGATHER in mpifx_allgather_${SUFFIX}$', error) + + end subroutine mpifx_allgather_${SUFFIX}$ + +#:enddef mpifx_allgather_dr1_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + + #:if RANK > 0 + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK) + $:mpifx_allgather_dr0_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + #:endif + + #:if RANK < MAX_RANK + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK + 1) + $:mpifx_allgather_dr1_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + #:endif + + #:endfor +#:endfor + +end module mpifx_allgather_module diff --git a/lib/mpifx_allgatherv.fpp b/lib/mpifx_allgatherv.fpp new file mode 100644 index 0000000..55898bb --- /dev/null +++ b/lib/mpifx_allgatherv.fpp @@ -0,0 +1,198 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(1, MAX_RANK + 1) + + +#! ************************************************************************ +#! *** mpifx_allgatherv +#! ************************************************************************ + + +#:def mpifx_allgatherv_dr0_template(SUFFIX, TYPE, RANK, MPI_TYPE) + + !> Gathers results of variable length on all processes (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for gathering. + !! \param recv Received data + !! \param recvcounts Counts of received data from each process + !! \param displs Entry i specifies where to place data from process rank i-1 + !! (default: computed from recvcounts assuming order with rank) + !! \param error Error code on exit. + !! + subroutine mpifx_allgatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ + integer, intent(in) :: recvcounts(:) + integer, intent(in), optional :: displs(:) + integer, intent(out), optional :: error + + integer :: error0, ii + integer, allocatable :: displs0(:) + + + @:ASSERT(size(recv) == sum(recvcounts)) + allocate(displs0(mycomm%size)) + if (present(displs)) then + @:ASSERT(size(displs) == mycomm%size) + displs0 = displs + else + displs0(1) = 0 + do ii = 2, mycomm%size + displs0(ii) = displs0(ii-1) + recvcounts(ii-1) + end do + end if + + call mpi_allgatherv(send, size(send), ${MPI_TYPE}$, recv, recvcounts, displs0, & + & ${MPI_TYPE}$, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_${SUFFIX}$", error) + + end subroutine mpifx_allgatherv_${SUFFIX}$ + +#:enddef + + + +#:def mpifx_allgatherv_dr1_template(SUFFIX, TYPE, SEND_RANK, SEND_BUFFER_SIZE, RECV_RANK, MPI_TYPE) + #! + #! + #! ${BUFFER_SIZE}$: send buffer size (1 or size(send)) + #! ${MPI_TYPE}$: corresponding MPI type + #! + !> Gathers results on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for gathering. + !! \param recv Received data on receive node (indefined on other nodes) + !! \param recvcounts Counts of received data from each process + !! \param displs Entry i specifies where to place data from process rank i-1 + !! (default: computed from recvcounts assuming order with rank) + !! \param error Error code on exit. + !! + subroutine mpifx_allgatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(SEND_RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RECV_RANK)}$ + integer, intent(in) :: recvcounts(:) + integer, intent(in), optional :: displs(:) + integer, intent(out), optional :: error + + integer :: ii, error0 + integer, allocatable :: displs0(:) + + @:ASSERT(size(recv) == sum(recvcounts)) + @:ASSERT(size(recv, dim=${RECV_RANK}$) == mycomm%size) + allocate(displs0(mycomm%size)) + if (present(displs)) then + @:ASSERT(size(displs) == mycomm%size) + displs0 = displs + else + displs0(1) = 0 + do ii = 2, mycomm%size + displs0(ii) = displs0(ii-1) + recvcounts(ii-1) + end do + end if + + call mpi_allgatherv(send, ${SEND_BUFFER_SIZE}$, ${MPI_TYPE}$, recv, recvcounts, displs0, & + & ${MPI_TYPE}$, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_${SUFFIX}$", error) + + end subroutine mpifx_allgatherv_${SUFFIX}$ + +#:enddef + +!> Contains wrapper for \c MPI_allgatherv +module mpifx_allgatherv_module + use mpifx_common_module + implicit none + private + + public :: mpifx_allgatherv + + !> Gathers scalars/arrays of different lengths on all nodes. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) and logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type. The third argument must have the size of the second times the number + !! of processes taking part in the gathering. The fourth argument must be + !! an array of integers corresponding to the array sizes received from each + !! processor. The displacements at which to place the incoming data can be + !! given as an optional argument. By default they are computed from recvcounts, + !! assuming ordering with processor rank. + !! + !! \see MPI documentation (\c MPI_allgatherv) + !! + !! Example: + !! + !! program test_allgatherv + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! real, allocatable :: send1(:) + !! real, allocatable :: recv1(:) + !! integer, allocatable :: recvcounts(:) + !! integer :: ii, nrecv + !! character(100) :: formstr + !! character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + !! + !! call mpifx_init() + !! call mycomm%init() + !! + !! ! I1 -> I1 + !! allocate(send1(mycomm%rank+1)) + !! send1 = 1.0*mycomm%rank + !! ! recv1 size is 1+2+3+...+mycomm%size + !! nrecv = mycomm%size*(mycomm%size+1)/2 + !! allocate(recv1(nrecv)) + !! recv1(:) = 0 + !! allocate(recvcounts(mycomm%size)) + !! do ii = 1, mycomm%size + !! recvcounts(ii) = ii + !! end do + !! + !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) + !! call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) + !! if (mycomm%lead) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_allgatherv + !! + interface mpifx_allgatherv + #:for TYPE in TYPES + #:for RANK in RANKS + #:set TYPEABBREV = TYPE_ABBREVS[TYPE] + module procedure mpifx_allgatherv_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK}$ + #:endfor + module procedure mpifx_allgatherv_${TYPEABBREV}$0${TYPEABBREV}$1 + #:endfor + end interface mpifx_allgatherv + + +contains + + #:for TYPE in TYPES + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + + #:for RANK in RANKS + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK) + $:mpifx_allgatherv_dr0_template(SUFFIX, FTYPE, RANK, MPITYPE) + #:endfor + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(0) + TYPE_ABBREVS[TYPE] + str(1) + $:mpifx_allgatherv_dr1_template(SUFFIX, FTYPE, 0, 1, 1, MPITYPE) + + #:endfor + +end module mpifx_allgatherv_module diff --git a/lib/mpifx_allreduce.fpp b/lib/mpifx_allreduce.fpp new file mode 100644 index 0000000..c3e30c8 --- /dev/null +++ b/lib/mpifx_allreduce.fpp @@ -0,0 +1,194 @@ +#:include 'mpifx.fypp' +#:set TYPES = NUMERIC_TYPES + LOGICAL_TYPES +#:set RANKS = range(MAX_RANK + 1) + +!> Contains wrapper for \c MPI_ALLREDUCE. +module mpifx_allreduce_module + use mpifx_common_module + implicit none + private + + public :: mpifx_allreduce, mpifx_allreduceip + + !> Reduces a scalar/array on all nodes. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) and logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type and rank. + !! + !! \see MPI documentation (\c MPI_ALLREDUCE) + !! + !! Example: + !! + !! program test_allreduce + !! use libmpifx_module + !! implicit none + !! + !! integer, parameter :: dp = kind(1.0d0) + !! + !! type(mpifx_comm) :: mycomm + !! real(dp) :: valr(3), resvalr(3) + !! + !! call mpifx_init() + !! call mycomm%init() + !! valr(:) = [ (mycomm%rank + 1) * 1.2_dp, & + !! & (mycomm%rank + 1) * 4.3_dp, (mycomm%rank + 1) * 3.8_dp ] + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + !! & "Value to be operated on:", valr(:) + !! call mpifx_allreduce(mycomm, valr, resvalr, MPI_PROD) + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + !! & "Obtained result (prod):", resvalr(:) + !! call mpifx_finalize() + !! + !! end program test_allreduce + !! + interface mpifx_allreduce +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_allreduce_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface mpifx_allreduce + + + !> Reduces a scalar/array on all nodes in place. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second argument. The second argument can be of type + !! integer (i), real (s), double precision (d), complex (c), double complex + !! (z) or logical (l). Its rank can vary from zero (scalar) up to the + !! maximum rank. + !! + !! \see MPI documentation (\c MPI_ALLREDUCE) + !! + !! + !! Example: + !! + !! program test_allreduceip + !! use libmpifx_module + !! implicit none + !! + !! integer, parameter :: dp = kind(1.0d0) + !! + !! type(mpifx_comm) :: mycomm + !! real(dp) :: resvalr(3) + !! + !! call mpifx_init() + !! call mycomm%init() + !! resvalr(:) = [ (mycomm%rank + 1) * 1.2_dp, & + !! & (mycomm%rank + 1) * 4.3_dp, (mycomm%rank + 1) * 3.8_dp ] + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + !! & "Value to be operated on:", resvalr(:) + !! call mpifx_allreduceip(mycomm, resvalr, MPI_PROD) + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + !! & "Obtained result (prod):", resvalr(:) + !! call mpifx_finalize() + !! + !! end program test_allreduceip + !! + interface mpifx_allreduceip +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_allreduceip_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface mpifx_allreduceip + +contains + +#:def mpifx_allreduce_template(SUFFIX, TYPE, MPITYPE, RANK) + + #:assert RANK >= 0 + + !> Reduces operand on all processes (type $1). + !! + !! See MPI documentation (mpi_allreduce()) for further details. + !! + subroutine mpifx_allreduce_${SUFFIX}$(mycomm, orig, reduced, reductionop, error) + + !> MPI communicator. + type(mpifx_comm), intent(in) :: mycomm + + !> Quantity to be reduced. + ${TYPE}$, intent(in) :: orig${RANKSUFFIX(RANK)}$ + + !> Contains result on exit. + ${TYPE}$, intent(inout) :: reduced${RANKSUFFIX(RANK)}$ + + !> Reduction operator + integer, intent(in) :: reductionop + + !> Error code on exit. + integer, intent(out), optional :: error + + integer :: error0 + + #:if RANK > 0 + @:ASSERT(size(orig) == size(reduced)) + #:endif + + #:set SIZE = '1' if RANK == 0 else 'size(orig)' + #:set COUNT = SIZE + + call mpi_allreduce(orig, reduced, ${COUNT}$, ${MPITYPE}$, reductionop, mycomm%id, error0) + call handle_errorflag(error0, 'MPI_ALLREDUCE in mpifx_allreduce_${SUFFIX}$', error) + + end subroutine mpifx_allreduce_${SUFFIX}$ + +#:enddef mpifx_allreduce_template + + +#:def mpifx_allreduceip_template(SUFFIX, TYPE, MPITYPE, RANK) + + #:assert RANK >= 0 + + !> Reduces operand on all processes (type ${SUFFIX}$). + !! + !! See MPI documentation (mpi_allreduce()) for further details. + !! + subroutine mpifx_allreduceip_${SUFFIX}$(mycomm, origreduced, reductionop, error) + + !> MPI communicator. + type(mpifx_comm), intent(in) :: mycomm + + !> Quantity to be reduced on input, reduced on exit. + ${TYPE}$, intent(inout) :: origreduced${RANKSUFFIX(RANK)}$ + + !> Reduction operator. + integer, intent(in) :: reductionop + + !> Error code on exit. + integer, intent(out), optional :: error + + integer :: error0 + + #:set SIZE = '1' if RANK == 0 else 'size(origreduced)' + #:set COUNT = SIZE + + call mpi_allreduce(MPI_IN_PLACE, origreduced, ${COUNT}$, ${MPITYPE}$, reductionop, mycomm%id,& + & error0) + call handle_errorflag(error0, "MPI_REDUCE in mpifx_allreduceip_${SUFFIX}$", error) + + end subroutine mpifx_allreduceip_${SUFFIX}$ + +#:enddef mpifx_allreduceip_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + + $:mpifx_allreduce_template(SUFFIX, FTYPE, MPITYPE, RANK) + $:mpifx_allreduceip_template(SUFFIX, FTYPE, MPITYPE, RANK) + + #:endfor +#:endfor + +end module mpifx_allreduce_module diff --git a/lib/mpifx_barrier.fpp b/lib/mpifx_barrier.fpp new file mode 100644 index 0000000..cf8efde --- /dev/null +++ b/lib/mpifx_barrier.fpp @@ -0,0 +1,47 @@ +#:include 'mpifx.fypp' + +!> Contains wrapper for \c MPI_BARRIER. +module mpifx_barrier_module + use mpifx_common_module + implicit none + private + + public :: mpifx_barrier + +contains + + !> Sets a barrier. + !! + !! \param mycomm MPI communicator. + !! \param error Optional error flag. + !! + !! Example: + !! + !! program test_barrier + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! + !! call mpifx_init() + !! call mycomm%init() + !! : + !! ! Processes will wait until all processes arrive here. + !! call mpifx_barrier(mycomm) + !! : + !! + !! end program test_barrier + !! + subroutine mpifx_barrier(mycomm, error) + type(mpifx_comm), intent(in) :: mycomm + integer, intent(out), optional :: error + + integer :: error0 + + call mpi_barrier(mycomm%id, error0) + call handle_errorflag(error0, "MPI_BARRIER in mpifx_barrier", error) + + end subroutine mpifx_barrier + + +end module mpifx_barrier_module diff --git a/lib/mpifx_bcast.fpp b/lib/mpifx_bcast.fpp new file mode 100644 index 0000000..264c1fb --- /dev/null +++ b/lib/mpifx_bcast.fpp @@ -0,0 +1,97 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(MAX_RANK + 1) + +!> Contains wrapper for \c MPI_BCAST. +module mpifx_bcast_module + use mpifx_common_module + implicit none + private + + public :: mpifx_bcast + + !> Broadcasts an MPI message to all nodes. + !! + !! \details All functions have the same argument list only differing in the type and rank of the + !! second argument. The second argument can be of type integer, real, double precision, complex, + !! double complex, logical and character. Its rank can vary from zero (scalar) up to the maximum + !! rank. + !! + !! \see MPI documentation (\c MPI_BCAST) + !! + !! Example: + !! + !! program test_bcast + !! use libmpifx_module + !! + !! type(mpifx) :: mycomm + !! integer :: buffer(3) + !! + !! call mycomm%init() + !! if (mycomm%lead) then + !! buffer(:) = [ 1, 2, 3 ] + !! end if + !! call mpifx_bcast(mycomm, buffer) + !! print "(A,I2.2,A,3I5)", "BUFFER:", mycomm%rank, ":", buffer + !! call mycomm%destruct() + !! + !! end program test_bcast + !! + interface mpifx_bcast +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_bcast_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface + +contains + +#:def mpifx_bcast_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK >= 0 + + !> Broadcasts an MPI message to all nodes (type ${SUFFIX}$). + !! + subroutine mpifx_bcast_${SUFFIX}$(mycomm, msg, root, error) + + !> MPI descriptor + type(mpifx_comm), intent(in) :: mycomm + + !> Msg to be broadcasted on root and received on non-root nodes. + ${TYPE}$ :: msg${RANKSUFFIX(RANK)}$ + + !> Root node for the broadcast (default: mycomm%leadrank). + integer, intent(in), optional :: root + + !> Optional error handling flag. + integer, intent(out), optional :: error + + integer :: root0, error0 + + #:set SIZE = '1' if RANK == 0 else 'size(msg)' + #:set COUNT = ('len(msg) * ' + SIZE if HASLENGTH else SIZE) + + call getoptarg(mycomm%leadrank, root0, root) + call mpi_bcast(msg, ${COUNT}$, ${MPITYPE}$, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_BCAST in mpifx_bcast_${SUFFIX}$", error) + + end subroutine mpifx_bcast_${SUFFIX}$ + +#:enddef mpifx_bcast_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + + $:mpifx_bcast_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:endfor +#:endfor + +end module mpifx_bcast_module diff --git a/lib/mpifx_comm.fpp b/lib/mpifx_comm.fpp new file mode 100644 index 0000000..fa99e76 --- /dev/null +++ b/lib/mpifx_comm.fpp @@ -0,0 +1,111 @@ +!> Contains the extended MPI communicator. +module mpifx_comm_module + use mpi + use mpifx_helper_module + implicit none + private + + public :: mpifx_comm + + !> MPI communicator with some additional information. + type mpifx_comm + integer :: id !< Communicator id. + integer :: size !< Nr. of processes (size). + integer :: rank !< Rank of the current process. + integer :: leadrank !< Index of the lead node. + logical :: lead !< True if current process is the lead (rank == 0). + contains + !> Initializes the MPI environment. + procedure :: init => mpifx_comm_init + + !> Creates a new communicator by splitting the old one. + procedure :: split => mpifx_comm_split + + end type mpifx_comm + +contains + + !> Initializes a communicator to contain all processes. + !! + !! \param self Initialized instance on exit. + !! \param commid MPI Communicator ID (default: \c MPI_COMM_WORLD) + !! \param error Error flag on return containing the first error occuring + !! during the calls mpi_comm_size and mpi_comm_rank. + !! + subroutine mpifx_comm_init(self, commid, error) + class(mpifx_comm), intent(out) :: self + integer, intent(in), optional :: commid + integer, intent(out), optional :: error + + integer :: error0 + + call getoptarg(MPI_COMM_WORLD, self%id, commid) + call mpi_comm_size(self%id, self%size, error0) + call handle_errorflag(error0, "mpi_comm_size() in mpifx_comm_init()", error) + if (error0 /= 0) then + return + end if + call mpi_comm_rank(self%id, self%rank, error0) + call handle_errorflag(error0, "mpi_comm_rank() in mpifx_comm_init()", error) + if (error0 /= 0) then + return + end if + self%leadrank = 0 + self%lead = (self%rank == self%leadrank) + + end subroutine mpifx_comm_init + + + !> Creates a new communicators by splitting the old one. + !! + !! \param self Communicator instance. + !! \param splitkey Key for the splitting. Processes invoking the routine + !! with the same value for splitkey will be belong to the same + !! communicator. + !! \param rankkey Is used to determine the rank of the process in its new + !! communicator. Processes calling the routine with a higher value will + !! have a higher rank in the new communicator. + !! \param newcomm New communicator for the given process. + !! \param error Optional error code on return. + !! + !! Example: + !! + !! program test_split + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: allproc, groupproc + !! integer :: groupsize, mygroup + !! + !! call mpifx_init() + !! call allproc%init() + !! groupsize = allproc%size / 2 + !! mygroup = allproc%rank / groupsize + !! call allproc%split(mygroup, allproc%rank, groupproc) + !! write(*, "(3(A,1X,I0,1X))") "ID:", allproc%rank, "SUBGROUP", & + !! & mygroup, "SUBGROUP ID", groupproc%rank + !! call mpifx_finalize() + !! + !! end program test_split + !! + !! \see MPI documentation (\c MPI_COMM_SPLIT) + !! + subroutine mpifx_comm_split(self, splitkey, rankkey, newcomm, error) + class(mpifx_comm), intent(inout) :: self + integer, intent(in) :: splitkey, rankkey + class(mpifx_comm), intent(out) :: newcomm + integer, intent(out), optional :: error + + integer :: error0, newcommid + + call mpi_comm_split(self%id, splitkey, rankkey, newcommid, error0) + call handle_errorflag(error0, "mpi_comm_split() in mpifx_comm_split()", error) + if (error0 /= 0) then + return + end if + call newcomm%init(newcommid, error) + + end subroutine mpifx_comm_split + + +end module mpifx_comm_module diff --git a/lib/mpifx_common.fpp b/lib/mpifx_common.fpp new file mode 100644 index 0000000..d00d1fc --- /dev/null +++ b/lib/mpifx_common.fpp @@ -0,0 +1,13 @@ +!> Exports constants, helper functions, MPI descriptor and legacy MPI routines. +!! \cond HIDDEN +module mpifx_common_module + use mpi + use mpifx_helper_module + use mpifx_comm_module + implicit none + + public + +end module mpifx_common_module + +!> \endcond diff --git a/lib/mpifx_constants.fpp b/lib/mpifx_constants.fpp new file mode 100644 index 0000000..c133034 --- /dev/null +++ b/lib/mpifx_constants.fpp @@ -0,0 +1,22 @@ +!> Exports some MPI constants. +!! \cond HIDDEN +module mpifx_constants_module + use mpi + private + + public :: MPI_MAX, MPI_MIN, MPI_SUM, MPI_PROD + public :: MPI_LAND, MPI_BAND, MPI_LOR, MPI_BOR, MPI_LXOR ,MPI_BXOR + public :: MPI_MAXLOC, MPI_MINLOC + public :: MPI_THREAD_SINGLE, MPI_THREAD_FUNNELED, MPI_THREAD_SERIALIZED, MPI_THREAD_MULTIPLE + public :: MPIFX_UNHANDLED_ERROR, MPIFX_ASSERT_FAILED + + + !> Exit code for errors which were not caught due to missing optional arguments + integer, parameter :: MPIFX_UNHANDLED_ERROR = 1 + + !> Exit code for failed assertions + integer, parameter :: MPIFX_ASSERT_FAILED = 2 + +end module mpifx_constants_module + +!> \endcond diff --git a/lib/mpifx_finalize.fpp b/lib/mpifx_finalize.fpp new file mode 100644 index 0000000..b9b98cc --- /dev/null +++ b/lib/mpifx_finalize.fpp @@ -0,0 +1,43 @@ +!> Contains wrapper for \c MPI_FINALIZE. +module mpifx_finalize_module + use mpifx_common_module + implicit none + private + + public :: mpifx_finalize + +contains + + !> Finalizes the MPI framework. + !! + !! \param error Error code on return. If not present and error code would have + !! been non-zero, routine aborts program execution. + !! + !! \see MPI documentation (\c MPI_FINALIZE) + !! + !! Example: + !! + !! program test_mpifx + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! + !! call mpifx_init() + !! call mycomm%init() + !! : + !! call mpifx_finalize() + !! + !! end program test_mpifx + !! + subroutine mpifx_finalize(error) + integer, intent(out), optional :: error + + integer :: error0 + + call mpi_finalize(error0) + call handle_errorflag(error0, "Error: mpi_finalize() in mpifx_finalize()", error) + + end subroutine mpifx_finalize + +end module mpifx_finalize_module diff --git a/lib/mpifx_gather.fpp b/lib/mpifx_gather.fpp new file mode 100644 index 0000000..b79bc2a --- /dev/null +++ b/lib/mpifx_gather.fpp @@ -0,0 +1,202 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(MAX_RANK + 1) + +!> Contains wrapper for \c MPI_GATHER +module mpifx_gather_module + use mpifx_common_module + implicit none + private + + public :: mpifx_gather + + !> Gathers scalars/arrays on a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) and logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type. The third argument must have the size of the second times the number + !! of processes taking part in the gathering. The third argument must have + !! either the same rank as the second one or one rank more. In latter case + !! the last dimension of it must be of the size of the number of processes + !! in the gathering. + !! + !! \see MPI documentation (\c MPI_GATHER) + !! + !! Example: + !! + !! program test_gather + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! integer :: send0 + !! integer, allocatable :: send1(:) + !! integer, allocatable :: recv1(:), recv2(:,:) + !! character(100) :: formstr + !! character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + !! + !! call mpifx_init() + !! call mycomm%init() + !! + !! ! I0 -> I1 + !! send0 = mycomm%rank * 2 ! Arbitrary number to send + !! if (mycomm%lead) then + !! allocate(recv1(1 * mycomm%size)) + !! recv1(:) = 0 + !! else + !! allocate(recv1(0)) + !! end if + !! write(*, *) mycomm%rank, "Send0 buffer:", send0 + !! call mpifx_gather(mycomm, send0, recv1) + !! if (mycomm%lead) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1(:) + !! end if + !! deallocate(recv1) + !! + !! ! I1 -> I1 + !! allocate(send1(2)) + !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers + !! if (mycomm%lead) then + !! allocate(recv1(size(send1) * mycomm%size)) + !! recv1(:) = 0 + !! else + !! allocate(recv1(0)) + !! end if + !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) + !! call mpifx_gather(mycomm, send1, recv1) + !! if (mycomm%lead) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! ! I1 -> I2 + !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + !! if (mycomm%lead) then + !! allocate(recv2(size(send1), mycomm%size)) + !! recv2(:,:) = 0 + !! end if + !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) + !! call mpifx_gather(mycomm, send1, recv2) + !! if (mycomm%lead) then + !! write(*, *) mycomm%rank, "Recv2 buffer:", recv2 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_gather + !! + interface mpifx_gather +#:for TYPE in TYPES + #:for RANK in RANKS + #:set TYPEABBREV = TYPE_ABBREVS[TYPE] + #:if RANK > 0 + module procedure mpifx_gather_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK}$ + #:endif + #:if RANK < MAX_RANK + module procedure mpifx_gather_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK + 1}$ + #:endif + #:endfor +#:endfor + end interface mpifx_gather + +contains + +#:def mpifx_gather_dr0_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK > 0 + + !> Gathers results on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for gathering. + !! \param recv Received data on receive node (undefined on other nodes) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_gather_${SUFFIX}$(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + #:set SIZE = 'size(send)' + #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(.not. mycomm%lead .or. size(recv) == size(send) * mycomm%size) + @:ASSERT(.not. mycomm%lead .or.& + & size(recv, dim=${RANK}$) == size(send, dim=${RANK}$) * mycomm%size) + + call getoptarg(mycomm%leadrank, root0, root) + call mpi_gather(send, ${COUNT}$, ${MPITYPE}$, recv, ${COUNT}$, ${MPITYPE}$, root0,& + & mycomm%id, error0) + call handle_errorflag(error0, "MPI_GATHER in mpifx_gather_${SUFFIX}$", error) + + end subroutine mpifx_gather_${SUFFIX}$ + +#:enddef mpifx_gather_dr0_template + + +#:def mpifx_gather_dr1_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK >= 0 + + !> Gathers results on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for gathering. + !! \param recv Received data on receive node (indefined on other nodes) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_gather_${SUFFIX}$(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK + 1)}$ + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + #:set SIZE = '1' if RANK == 0 else 'size(send)' + #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(.not. mycomm%lead .or. size(recv) == ${SIZE}$ * mycomm%size) + @:ASSERT(.not. mycomm%lead .or. size(recv, dim=${RANK + 1}$) == mycomm%size) + + call getoptarg(mycomm%leadrank, root0, root) + call mpi_gather(send, ${SIZE}$, ${MPITYPE}$, recv, ${SIZE}$, ${MPITYPE}$, root0, mycomm%id,& + & error0) + call handle_errorflag(error0, "MPI_GATHER in mpifx_gather_${SUFFIX}$", error) + + end subroutine mpifx_gather_${SUFFIX}$ + +#:enddef mpifx_gather_dr1_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + + #:if RANK > 0 + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK) + $:mpifx_gather_dr0_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + #:endif + + #:if RANK < MAX_RANK + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK + 1) + $:mpifx_gather_dr1_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + #:endif + + #:endfor +#:endfor + + +end module mpifx_gather_module diff --git a/lib/mpifx_gatherv.fpp b/lib/mpifx_gatherv.fpp new file mode 100644 index 0000000..c1cb677 --- /dev/null +++ b/lib/mpifx_gatherv.fpp @@ -0,0 +1,227 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(1, MAX_RANK + 1) + +#! ************************************************************************ +#! *** mpifx_gatherv +#! ************************************************************************ + + +#:def mpifx_gatherv_dr0_template(SUFFIX, TYPE, RANK, MPI_TYPE) + + !> Gathers results of variable length on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for gathering. + !! \param recv Received data on receive node (undefined on other nodes) + !! \param recvcounts Counts of received data from each process + !! \param displs Entry i specifies where to place data from process rank i-1 + !! (default: computed from recvcounts assuming order with rank) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_gatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ + integer, intent(in) :: recvcounts(:) + integer, intent(in), optional :: displs(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0, ii, locLast(1), aborterror + integer, allocatable :: displs0(:) + logical, allocatable :: testBuffer(:) + + @:inoptflags(root0, root, mycomm%leadrank) + + if (mycomm%rank == root0) then + allocate(displs0(mycomm%size)) + if (present(displs)) then + @:ASSERT(size(displs) == mycomm%size) + displs0 = displs + locLast = maxloc(displs0) + @:ASSERT(size(recv) >= displs0(locLast(1)) + recvcounts(locLast(1))) + ! test for overlapping regions being written to + allocate(testBuffer(size(recv))) + testBuffer = .false. + do ii = 1, mycomm%size + ! potentially in random order, so mark effected parts of the buffer + if (any(testBuffer(displs0(ii):displs0(ii)+recvcounts(ii)-1))) then + write(*, "(A)") "Overlapping regions in mpifx_gatherv!" + call mpi_abort(MPI_COMM_WORLD, -1, aborterror) + if (aborterror /= 0) then + write(*, "(A)") "Stopping code did not succeed, hope for the best." + end if + end if + testBuffer(displs0(ii):displs0(ii)+recvcounts(ii)-1) = .true. + end do + deallocate(testBuffer) + else + displs0(1) = 0 + do ii = 2, mycomm%size + displs0(ii) = displs0(ii-1) + recvcounts(ii-1) + end do + @:ASSERT(sum(recvcounts) == size(recv)) + end if + end if + + call mpi_gatherv(send, size(send), ${MPI_TYPE}$, recv, recvcounts, displs0, & + & ${MPI_TYPE}$, root0, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_${SUFFIX}$", error) + + end subroutine mpifx_gatherv_${SUFFIX}$ + +#:enddef + + + +#:def mpifx_gatherv_dr1_template(SUFFIX, TYPE, SEND_RANK, SEND_SIZE, RECV_RANK, MPI_TYPE) + + !> Gathers results on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for gathering. + !! \param recv Received data on receive node (indefined on other nodes) + !! \param recvcounts Counts of received data from each process + !! \param displs Entry i specifies where to place data from process rank i-1 + !! (default: computed from recvcounts assuming order with rank) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_gatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(SEND_RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RECV_RANK)}$ + integer, intent(in) :: recvcounts(:) + integer, intent(in), optional :: displs(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: ii, root0, error0 + integer, allocatable :: displs0(:) + + @:inoptflags(root0, root, mycomm%leadrank) + + if (mycomm%rank == root0) then + @:ASSERT(size(recv) == sum(recvcounts)) + @:ASSERT(size(recv, dim=${RECV_RANK}$) == mycomm%size) + allocate(displs0(mycomm%size)) + if (present(displs)) then + @:ASSERT(size(displs) == mycomm%size) + displs0 = displs + else + displs0(1) = 0 + do ii = 2, mycomm%size + displs0(ii) = displs0(ii-1) + recvcounts(ii-1) + end do + end if + end if + + call mpi_gatherv(send, ${SEND_SIZE}$, ${MPI_TYPE}$, recv, recvcounts, displs0, & + & ${MPI_TYPE}$, root0, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_${SUFFIX}$", error) + + end subroutine mpifx_gatherv_${SUFFIX}$ + +#:enddef + + +!> Contains wrapper for \c MPI_gatherv +module mpifx_gatherv_module + use mpifx_common_module + implicit none + private + + public :: mpifx_gatherv + + !> Gathers scalars/arrays of different lengths on a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) and logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type. The third argument must have the size of the second times the number + !! of processes taking part in the gathering. The fourth argument must be + !! an array of integers corresponding to the array sizes received from each + !! processor. The displacements at which to place the incoming data can be + !! given as an optional argument. By default they are computed from recvcounts, + !! assuming ordering with processor rank. + !! + !! \see MPI documentation (\c MPI_gatherv) + !! + !! Example: + !! + !! program test_gatherv + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! real, allocatable :: send1(:) + !! real, allocatable :: recv1(:) + !! integer, allocatable :: recvcounts(:) + !! integer :: ii, nrecv + !! character(100) :: formstr + !! character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + !! + !! call mpifx_init() + !! call mycomm%init() + !! + !! ! I1 -> I1 + !! allocate(send1(mycomm%rank+1)) + !! send1 = 1.0*mycomm%rank + !! if (mycomm%lead) then + !! ! recv1 size is 1+2+3+...+mycomm%size + !! nrecv = mycomm%size*(mycomm%size+1)/2 + !! allocate(recv1(nrecv)) + !! recv1(:) = 0 + !! allocate(recvcounts(mycomm%size)) + !! do ii = 1, mycomm%size + !! recvcounts(ii) = ii + !! end do + !! else + !! allocate(recv1(0)) + !! end if + !! + !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) + !! call mpifx_gatherv(mycomm, send1, recv1, recvcounts) + !! if (mycomm%lead) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_gatherv + !! + interface mpifx_gatherv + #:for TYPE in TYPES + #:for RANK in RANKS + #:set TYPEABBREV = TYPE_ABBREVS[TYPE] + module procedure mpifx_gatherv_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK}$ + #:endfor + module procedure mpifx_gatherv_${TYPEABBREV}$0${TYPEABBREV}$1 + #:endfor + end interface mpifx_gatherv + + +contains + + #:for TYPE in TYPES + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + + #:for RANK in RANKS + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK) + $:mpifx_gatherv_dr0_template(SUFFIX, FTYPE, RANK, MPITYPE) + #:endfor + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(0) + TYPE_ABBREVS[TYPE] + str(1) + $:mpifx_gatherv_dr1_template(SUFFIX, FTYPE, 0, 1, 1, MPITYPE) + + #:endfor + +end module mpifx_gatherv_module diff --git a/lib/mpifx_get_processor_name.fpp b/lib/mpifx_get_processor_name.fpp new file mode 100644 index 0000000..7e274b6 --- /dev/null +++ b/lib/mpifx_get_processor_name.fpp @@ -0,0 +1,34 @@ +!> Contains the extended MPI communicator. +module mpifx_get_processor_name_module + use mpifx_helper_module + use mpi + implicit none + private + + public :: mpifx_get_processor_name + +contains + + !> Returns the name of the processor/machine on which current process runs. + !! + !! \param rankname Name of the processor (machine) on return. + !! \param error Error flag on return. + !! + subroutine mpifx_get_processor_name(rankname, error) + character(:), allocatable, intent(out) :: rankname + integer, intent(out), optional :: error + + integer :: error0, length + character(MPI_MAX_PROCESSOR_NAME) :: buffer + + call mpi_get_processor_name(buffer, length, error0) + call handle_errorflag(error0, "mpi_get_processor_name() in mpifx_get_processor_name", error) + if (error0 /= 0) then + return + end if + rankname = buffer(1:length) + + end subroutine mpifx_get_processor_name + + +end module mpifx_get_processor_name_module diff --git a/lib/mpifx_helper.fpp b/lib/mpifx_helper.fpp new file mode 100644 index 0000000..70fa09b --- /dev/null +++ b/lib/mpifx_helper.fpp @@ -0,0 +1,153 @@ +#:include 'mpifx.fypp' +#:set OPT_ARG_RANKS = (0, 1) + +!> Exports constants and helper routine(s). +!! \cond HIDDEN +module mpifx_helper_module + use mpi + use, intrinsic :: iso_fortran_env, only : stderr => error_unit + use mpifx_constants_module + implicit none + private + + public :: default_tag, sp, dp + public :: handle_errorflag, assert_failed + public :: getoptarg, setoptarg + + !> Default tag + integer, parameter :: default_tag = 0 + + !> Single precision kind. + integer, parameter :: sp = kind(1.0) + + !> Double precision kind. + integer, parameter :: dp = kind(1.0d0) + + + interface getoptarg +#:for RANK in OPT_ARG_RANKS + #:for TYPE in ALL_TYPES + module procedure getoptarg_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface getoptarg + + + interface setoptarg +#:for RANK in OPT_ARG_RANKS + #:for TYPE in ALL_TYPES + module procedure setoptarg_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface setoptarg + + +contains + + !> Handles optional error flag. + !! + subroutine handle_errorflag(error0, msg, error) + + !> Error flag as returned by some routine. + integer, intent(in) :: error0 + + !> Msg to print out, if program is stopped. + character(*), intent(in) :: msg + + !> Optional error flag. + !! + !! If present, error0 is passed to it, otherwise if error0 was not zero, the + !! error message in msg is printed and the program is stopped. + !! + integer, intent(out), optional :: error + + integer :: aborterror + + if (present(error)) then + error = error0 + elseif (error0 /= 0) then + write(stderr, "(A)") "Operation failed!" + write(stderr, "(A)") msg + write(stderr, "(A,I0)") "Error: ", error0 + call mpi_abort(MPI_COMM_WORLD, MPIFX_UNHANDLED_ERROR, aborterror) + if (aborterror /= 0) then + write(stderr, "(A)") "Stopping code with 'mpi_abort' did not succeed, trying 'stop' instead" + stop 1 + end if + end if + + end subroutine handle_errorflag + + + !> Stops code signalizing a failed assert condition + !! + subroutine assert_failed(file, line) + character(*), intent(in) :: file + integer, intent(in) :: line + + integer :: aborterror + + write(stderr, "(A)") "Assertion failed" + write(stderr, "(A,A)") "File:", file + write(stderr, "(A,I0)") "Line:", line + call mpi_abort(MPI_COMM_WORLD, MPIFX_ASSERT_FAILED, aborterror) + if (aborterror /= 0) then + write(stderr, "(A)") "Stopping code with 'mpi_abort' did not succeed, trying 'stop' instead" + stop 1 + end if + + end subroutine assert_failed + + +#:def getoptarg_template(SUFFIX, TYPE, RANK) + + #:assert RANK >= 0 + + subroutine getoptarg_${SUFFIX}$(defarg, arg, optarg) + ${TYPE}$, intent(in) :: defarg${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: arg${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(in), optional :: optarg${RANKSUFFIX(RANK)}$ + + if (present(optarg)) then + arg = optarg + else + arg = defarg + end if + + end subroutine getoptarg_${SUFFIX}$ + +#:enddef + + +#:def setoptarg_template(SUFFIX, TYPE, RANK) + + #:assert RANK >= 0 + + subroutine setoptarg_${SUFFIX}$(curval, optval) + ${TYPE}$, intent(in) :: curval${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out), optional :: optval${RANKSUFFIX(RANK)}$ + + if (present(optval)) then + optval = curval + end if + + end subroutine setoptarg_${SUFFIX}$ + +#:enddef + + +#:for TYPE in ALL_TYPES + #:for RANK in OPT_ARG_RANKS + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + #:set FTYPE = FORTRAN_TYPES[TYPE] + + $:getoptarg_template(SUFFIX, FTYPE, RANK) + $:setoptarg_template(SUFFIX, FTYPE, RANK) + + #:endfor +#:endfor + +end module mpifx_helper_module + +!> \endcond diff --git a/lib/mpifx_init.fpp b/lib/mpifx_init.fpp new file mode 100644 index 0000000..387b758 --- /dev/null +++ b/lib/mpifx_init.fpp @@ -0,0 +1,91 @@ +!> Contains wrapper for \c MPI_INIT. +module mpifx_init_module + use mpifx_common_module + use mpifx_constants_module + implicit none + private + + public :: mpifx_init, mpifx_init_thread + +contains + + !> Initializes the MPI environment. + !! + !! \param error Error code on return. If not present and error code would have + !! been non-zero, routine aborts program execution. + !! + !! \see MPI documentation (\c MPI_INIT) + !! + !! Example: + !! + !! program test_mpifx + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! + !! call mpifx_init() + !! call mycomm%init() + !! : + !! call mpifx_finalize() + !! + !! end program test_mpifx + !! + subroutine mpifx_init(error) + integer, intent(out), optional :: error + + integer :: error0 + + call mpi_init(error0) + call handle_errorflag(error0, "Error: mpi_init() in mpifx_init()", error) + + end subroutine mpifx_init + + !> Initializes a threaded MPI environment. + !! + !! \param requiredThreading Threading support required (MPI_THREAD_SINGLE, MPI_THREAD_FUNNELED, + !! MPI_THREAD_SERIALIZED, MPI_THREAD_MULTIPLE) + !! \param proviedeThreading Threading level provided by the MPI-framework. If not present and + !! the framework offers a lower support than required, the routine stops program execution. + !! \param error Error code on return. If not present and error code would have been non-zero, + !! routine aborts program execution. + !! + !! \see MPI documentation (\c MPI_INIT) + !! + !! Example: + !! + !! program test_mpifx + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! + !! call mpifx_init_thread(MPI_THREAD_FUNNELED) + !! call mycomm%init() + !! : + !! call mpifx_finalize() + !! + !! end program test_mpifx + !! + + subroutine mpifx_init_thread(requiredThreading, providedThreading, error) + integer, intent(in) :: requiredThreading + integer, intent(out), optional :: providedThreading + integer, intent(out), optional :: error + + integer :: error0, providedThreading0 + + call mpi_init_thread(requiredThreading, providedThreading0, error0) + if (present(providedThreading)) then + providedThreading = providedThreading0 + elseif (providedThreading0 < requiredThreading) then + write(*, "(A,I0,A,I0,A)") "Error: Provided threading model (", providedThreading0,& + & ") is less than required threading model (", requiredThreading, ")" + call mpi_abort(MPI_COMM_WORLD, MPIFX_UNHANDLED_ERROR, error0) + end if + call handle_errorflag(error0, "Error: mpi_init_thread in mpifx_init_thread()", error) + + end subroutine mpifx_init_thread + + +end module mpifx_init_module diff --git a/lib/mpifx_recv.fpp b/lib/mpifx_recv.fpp new file mode 100644 index 0000000..d5ec093 --- /dev/null +++ b/lib/mpifx_recv.fpp @@ -0,0 +1,110 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(MAX_RANK + 1) + +!> Contains wrapper for \c MPI_RECV +module mpifx_recv_module + use mpifx_common_module + implicit none + private + + public :: mpifx_recv + + + !> Receives a message from a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second argument. The second argument can be of + !! type integer (i), real (s), double precision (d), complex (c), + !! double complex (z), logical (b) and character (h). Its rank can vary from + !! zero (scalar) up to the maximum rank. + !! + !! \see MPI documentation (\c MPI_RECV) + !! + !! Example: + !! + !! program hello + !! use libmpifx_module + !! implicit none + !! + !! character(100) :: msg + !! type(mpifx) :: mycomm + !! integer :: source + !! + !! call mpifx_init() + !! call mycomm%init() + !! if (.not. mycomm%lead) then + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + !! call mpifx_send(mycomm, msg, mycomm%leadrank) + !! else + !! write(*, "(A)") "Lead node:" + !! do source = 1, mycomm%size - 1 + !! call mpifx_recv(mycomm, msg, source) + !! write(*,"(A,A)") "Message received: ", trim(msg) + !! end do + !! end if + !! call mpifx_finalize() + !! + !! end program hello + !! + interface mpifx_recv +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_recv_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface mpifx_recv + +contains + +#:def mpifx_recv_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK >= 0 + + !> Receives a message from a given process. + !! \param mycomm MPI descriptor. + !! \param msg Msg to be received. + !! \param source Optional source process (default: MPI_ANY_SOURCE) + !! \param tag Optional message tag (default: MPI_ANY_TAG). + !! \param status Optional status array. + !! \param error Optional error handling flag. + !! + subroutine mpifx_recv_${SUFFIX}$(mycomm, msg, source, tag, status, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(out) :: msg${RANKSUFFIX(RANK)}$ + integer, intent(in), optional :: source, tag + integer, intent(out), optional :: status(MPI_STATUS_SIZE) + integer, intent(out), optional :: error + + integer :: source0, tag0, error0 + integer :: status0(MPI_STATUS_SIZE) + + call getoptarg(MPI_ANY_TAG, tag0, tag) + call getoptarg(MPI_ANY_SOURCE, source0, source) + + #:set SIZE = '1' if RANK == 0 else 'size(msg)' + #:set COUNT = ('len(msg) * ' + SIZE if HASLENGTH else SIZE) + + call mpi_recv(msg, ${COUNT}$, ${MPITYPE}$, source0, tag0, mycomm%id, status0, error0) + call handle_errorflag(error0, "MPI_RECV in mpifx_recv_${SUFFIX}$", error) + call setoptarg(status0, status) + + end subroutine mpifx_recv_${SUFFIX}$ + +#:enddef mpifx_recv_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + + $:mpifx_recv_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:endfor +#:endfor + +end module mpifx_recv_module diff --git a/lib/mpifx_reduce.fpp b/lib/mpifx_reduce.fpp new file mode 100644 index 0000000..b14fdb3 --- /dev/null +++ b/lib/mpifx_reduce.fpp @@ -0,0 +1,192 @@ +#:include 'mpifx.fypp' +#:set TYPES = NUMERIC_TYPES + LOGICAL_TYPES +#:set RANKS = range(MAX_RANK + 1) + +!> Contains wrapper for \c MPI_REDUCE. +module mpifx_reduce_module + use mpifx_common_module + implicit none + private + + public :: mpifx_reduce, mpifx_reduceip + + !> Reduces a scalar/array on a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) or logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type and rank. + !! + !! \see MPI documentation (\c MPI_REDUCE) + !! + !! Example: + !! + !! program test_reduce + !! use libmpifx_module + !! implicit none + !! + !! integer, parameter :: dp = kind(1.0d0) + !! + !! type(mpifx_comm) :: mycomm + !! real(dp) :: valr(3), resvalr(3) + !! + !! call mpifx_init() + !! call mycomm%init() + !! valr(:) = [ (mycomm%rank + 1) * 1.2_dp, & + !! & (mycomm%rank + 1) * 4.3_dp, (mycomm%rank + 1) * 3.8_dp ] + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + !! & "Value to be operated on:", valr(:) + !! call mpifx_reduce(mycomm, valr, resvalr, MPI_PROD) + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + !! & "Obtained result (prod):", resvalr(:) + !! call mpifx_finalize() + !! + !! end program test_reduce + !! + interface mpifx_reduce +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_reduce_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface mpifx_reduce + + + !> Reduces a scalar/array on a given node in place. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second argument. The second argument can be of type + !! integer (i), real (s), double precision (d), complex (c), double complex + !! (z) or logical (l). Its rank can vary from zero (scalar) up to the + !! maximum rank. + !! + !! \see MPI documentation (\c MPI_REDUCE) + !! + !! + !! Example: + !! + !! program test_reduceip + !! use libmpifx_module + !! implicit none + !! + !! integer, parameter :: dp = kind(1.0d0) + !! + !! type(mpifx_comm) :: mycomm + !! real(dp) :: resvalr(3) + !! + !! call mpifx_init() + !! call mycomm%init() + !! resvalr(:) = [ (mycomm%rank + 1) * 1.2_dp, & + !! & (mycomm%rank + 1) * 4.3_dp, (mycomm%rank + 1) * 3.8_dp ] + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + !! & "Value to be operated on:", resvalr(:) + !! call mpifx_reduceip(mycomm, resvalr, MPI_PROD) + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + !! & "Obtained result (prod):", resvalr(:) + !! call mpifx_finalize() + !! + !! end program test_reduceip + !! + interface mpifx_reduceip +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_reduceip_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface mpifx_reduceip + +contains + +#:def mpifx_reduce_template(SUFFIX, TYPE, MPITYPE, RANK) + + #:assert RANK >= 0 + + !> Reduces on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param orig Quantity to be reduced. + !! \param reduced Contains result on exit. + !! \param reduceop Reduction operator. + !! \param root Root process for the reduced (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_reduce_${SUFFIX}$(mycomm, orig, reduced, reduceop, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: orig${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(inout) :: reduced${RANKSUFFIX(RANK)}$ + integer, intent(in) :: reduceop + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + call getoptarg(mycomm%leadrank, root0, root) + + #:set SIZE = '1' if RANK == 0 else 'size(orig)' + #:set COUNT = SIZE + + call mpi_reduce(orig, reduced, ${COUNT}$, ${MPITYPE}$, reduceop, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_${SUFFIX}$", error) + + end subroutine mpifx_reduce_${SUFFIX}$ + +#:enddef mpifx_reduce_template + + +#:def mpifx_reduceip_template(SUFFIX, TYPE, MPITYPE, RANK) + + #:assert RANK >= 0 + + !> Reduces results on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param origred Quantity to be reduced on input, result on exit + !! \param reduceop Reduction reduceop + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_reduceip_${SUFFIX}$(mycomm, origred, reduceop, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(inout) :: origred${RANKSUFFIX(RANK)}$ + integer, intent(in) :: reduceop + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + ${TYPE}$ :: dummy + + call getoptarg(mycomm%leadrank, root0, root) + + #:set SIZE = '1' if RANK == 0 else 'size(origred)' + #:set COUNT = SIZE + + if (mycomm%rank == root0) then + call mpi_reduce(MPI_IN_PLACE, origred, ${COUNT}$, ${MPITYPE}$, reduceop, root0, mycomm%id,& + & error0) + else + call mpi_reduce(origred, dummy, ${COUNT}$, ${MPITYPE}$, reduceop, root0, mycomm%id, & + & error0) + end if + call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_${SUFFIX}$", error) + + end subroutine mpifx_reduceip_${SUFFIX}$ + +#:enddef mpifx_reduceip_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + + $:mpifx_reduce_template(SUFFIX, FTYPE, MPITYPE, RANK) + $:mpifx_reduceip_template(SUFFIX, FTYPE, MPITYPE, RANK) + + #:endfor +#:endfor + +end module mpifx_reduce_module diff --git a/lib/mpifx_scatter.fpp b/lib/mpifx_scatter.fpp new file mode 100644 index 0000000..de288b9 --- /dev/null +++ b/lib/mpifx_scatter.fpp @@ -0,0 +1,189 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(1, MAX_RANK + 1) + +!> Contains wrapper for \c MPI_SCATTER +module mpifx_scatter_module + use mpifx_common_module + implicit none + private + + public :: mpifx_scatter + + !> Scatters scalars/arrays on a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) and logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type. The second argument must have the size of the third times the number + !! of processes taking part in the scattering. The second argument must have + !! either the same rank as the third one or one rank more. In latter case + !! the last dimension of it must be of the size of the number of processes + !! in the scattering. + !! + !! \see MPI documentation (\c MPI_SCATTER) + !! + !! Example: + !! + !! program test_scatter + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! integer, allocatable :: send1(:), send2(:,:) + !! integer :: recv0 + !! integer, allocatable :: recv1(:) + !! integer :: ii + !! + !! call mpifx_init() + !! call mycomm%init() + !! + !! ! I1 -> I0 + !! if (mycomm%lead) then + !! allocate(send1(mycomm%size)) + !! send1(:) = [ (ii, ii = 1, size(send1)) ] + !! write(*, *) mycomm%rank, "Send1 buffer:", send1 + !! else + !! allocate(send1(0)) + !! end if + !! recv0 = 0 + !! call mpifx_scatter(mycomm, send1, recv0) + !! write(*, *) mycomm%rank, "Recv0 buffer:", recv0 + !! + !! ! I1 -> I1 + !! if (mycomm%lead) then + !! deallocate(send1) + !! allocate(send1(2 * mycomm%size)) + !! send1(:) = [ (ii, ii = 1, size(send1)) ] + !! write(*, *) mycomm%rank, "Send1 buffer:", send1 + !! end if + !! allocate(recv1(2)) + !! recv1(:) = 0 + !! call mpifx_scatter(mycomm, send1, recv1) + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! + !! ! I2 -> I1 + !! if (mycomm%lead) then + !! allocate(send2(2, mycomm%size)) + !! send2(:,:) = reshape(send1, [ 2, mycomm%size ]) + !! write(*, *) mycomm%rank, "Send2 buffer:", send2 + !! else + !! allocate(send2(0,0)) + !! end if + !! recv1(:) = 0 + !! call mpifx_scatter(mycomm, send2, recv1) + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! + !! call mpifx_finalize() + !! + !! end program test_scatter + !! + interface mpifx_scatter +#:for TYPE in TYPES + #:for RANK in RANKS + #:set TYPEABBREV = TYPE_ABBREVS[TYPE] + module procedure mpifx_scatter_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK}$ + module procedure mpifx_scatter_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK - 1}$ + #:endfor +#:endfor + end interface mpifx_scatter + +contains + +#:def mpifx_scatter_dr0_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK > 0 + + !> Scatters object from one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for scattering. + !! \param recv Received data on receive node (undefined on other nodes) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_scatter_${SUFFIX}$(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + #:set SIZE = 'size(recv)' + #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(.not. mycomm%lead .or. size(send) == size(recv) * mycomm%size) + @:ASSERT(.not. mycomm%lead& + & .or. size(send, dim=${RANK}$) == size(recv, dim=${RANK}$) * mycomm%size) + + call getoptarg(mycomm%leadrank, root0, root) + call mpi_scatter(send, ${COUNT}$, ${MPITYPE}$, recv, ${COUNT}$, ${MPITYPE}$, root0,& + & mycomm%id, error0) + call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatter_${SUFFIX}$", error) + + end subroutine mpifx_scatter_${SUFFIX}$ + +#:enddef mpifx_scatter_dr0_template + + +#:def mpifx_scatter_dr1_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK > 0 + + !> Scatters results on one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for scattering. + !! \param recv Received data on receive node (indefined on other nodes) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_scatter_${SUFFIX}$(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK - 1)}$ + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + #:set SIZE = '1' if RANK == 1 else 'size(recv)' + #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(.not. mycomm%lead .or. size(send) == ${SIZE}$ * mycomm%size) + @:ASSERT(.not. mycomm%lead .or. size(send, dim=${RANK}$) == mycomm%size) + #:if HASLENGTH + @:ASSERT(.not. mycomm%lead .or. len(send) == len(recv)) + #:endif + + call getoptarg(mycomm%leadrank, root0, root) + call mpi_scatter(send, ${COUNT}$, ${MPITYPE}$, recv, ${COUNT}$, ${MPITYPE}$, root0,& + & mycomm%id, error0) + call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatter_${SUFFIX}$", error) + + end subroutine mpifx_scatter_${SUFFIX}$ + +#:enddef mpifx_scatter_dr1_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK) + $:mpifx_scatter_dr0_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK - 1) + $:mpifx_scatter_dr1_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:endfor +#:endfor + +end module mpifx_scatter_module diff --git a/lib/mpifx_scatterv.fpp b/lib/mpifx_scatterv.fpp new file mode 100644 index 0000000..aaa4944 --- /dev/null +++ b/lib/mpifx_scatterv.fpp @@ -0,0 +1,217 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES +#:set RANKS = range(1, MAX_RANK + 1) + +!> Contains wrapper for \c MPI_SCATTER +module mpifx_scatterv_module + use mpifx_common_module + implicit none + private + + public :: mpifx_scatterv + + !> scatters scalars/arrays of different lengths from a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second and third arguments. The second and third + !! arguments can be of type integer (i), real (s), double precision (d), + !! complex (c), double complex (z) and logical (l). Their rank can vary from + !! zero (scalars) up to the maximum rank. Both arguments must be of same + !! type. The second argument must have the size of the third times the number + !! of processes taking part in the scattering. The second argument must have + !! either the same rank as the third one or one rank more. In latter case + !! the last dimension of it must be of the size of the number of processes + !! in the scatterving. + !! + !! \see MPI documentation (\c MPI_scatterv) + !! + !! Example: + !! + !! program test_scatterv + !! use libmpifx_module + !! implicit none + !! + !! type(mpifx_comm) :: mycomm + !! integer, allocatable :: send1(:) + !! integer, allocatable :: recv1(:) + !! integer, allocatable :: sendcounts(:) + !! integer :: ii, nsend + !! + !! call mpifx_init() + !! call mycomm%init() + !! + !! ! I1 -> I1 + !! allocate(recv1(mycomm%rank+1)) + !! recv1 = 0 + !! if (mycomm%lead) then + !! ! send1 size is 1+2+3+...+mycomm%size + !! nsend = mycomm%size*(mycomm%size+1)/2 + !! allocate(send1(nsend)) + !! do ii = 1, nsend + !! send1(ii) = ii + !! end do + !! allocate(sendcounts(mycomm%size)) + !! do ii = 1, mycomm%size + !! sendcounts(ii) = ii + !! end do + !! else + !! allocate(send1(0)) + !! end if + !! + !! if (mycomm%lead) then + !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) + !! end if + !! call mpifx_scatterv(mycomm, send1, sendcounts, recv1) + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! + !! call mpifx_finalize() + !! + !! end program test_scatterv + !! + interface mpifx_scatterv +#:for TYPE in TYPES + #:for RANK in RANKS + #:set TYPEABBREV = TYPE_ABBREVS[TYPE] + module procedure mpifx_scatterv_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK}$ + module procedure mpifx_scatterv_${TYPEABBREV}$${RANK}$${TYPEABBREV}$${RANK - 1}$ + #:endfor +#:endfor + end interface mpifx_scatterv + +contains + +#:def mpifx_scatterv_dr0_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK > 0 + + !> scatters object of variable length from one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for scattering. + !! \param sendcounts Counts of sent data from each process + !! \param recv Received data on receive node (undefined on other nodes) + !! \param displs Entry i specifies where to take data to send to rank i + !! (default: computed from sendcounts assuming order with rank) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_scatterv_${SUFFIX}$(mycomm, send, sendcounts, recv, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + integer, intent(in) :: sendcounts(:) + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ + integer, intent(in), optional :: displs(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0, ii + integer, allocatable :: displs0(:) + + #:set SIZE = 'size(recv)' + #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(.not. mycomm%lead .or. size(send) == size(recv) * mycomm%size) + @:ASSERT(.not. mycomm%lead& + & .or. size(send, dim=${RANK}$) == size(recv, dim=${RANK}$) * mycomm%size) + + call getoptarg(mycomm%leadrank, root0, root) + if (mycomm%rank == root0) then + if (present(displs)) then + @:ASSERT(size(displs) == mycomm%size) + allocate(displs0(mycomm%size)) + displs0(:) = displs + else + allocate(displs0(mycomm%size)) + displs0(1) = 0 + do ii = 2, mycomm%size + displs0(ii) = displs0(ii-1) + sendcounts(ii-1) + end do + end if + end if + call mpi_scatterv(send, sendcounts, displs0, ${MPITYPE}$, recv, ${SIZE}$, ${MPITYPE}$, root0,& + & mycomm%id, error0) + + call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatterv_${SUFFIX}$", error) + + end subroutine mpifx_scatterv_${SUFFIX}$ + +#:enddef mpifx_scatterv_dr0_template + + +#:def mpifx_scatterv_dr1_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + #:assert RANK > 0 + + !> Scatter results from one process (type ${SUFFIX}$). + !! + !! \param mycomm MPI communicator. + !! \param send Quantity to be sent for scattering. + !! \param sendcounts Counts of sent data from each process + !! \param recv Received data on receive node (indefined on other nodes) + !! \param displs Entry i specifies where to take data to send to rank i + !! (default: computed from sendcounts assuming order with rank) + !! \param root Root process for the result (default: mycomm%leadrank) + !! \param error Error code on exit. + !! + subroutine mpifx_scatterv_${SUFFIX}$(mycomm, send, sendcounts, recv, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + integer, intent(in) :: sendcounts(:) + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK - 1)}$ + integer, intent(in), optional :: displs(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0, ii + integer, allocatable :: displs0(:) + + #:set SIZE = '1' if RANK == 1 else 'size(recv)' + #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) + + @:ASSERT(.not. mycomm%lead .or. size(send) == ${SIZE}$ * mycomm%size) + @:ASSERT(.not. mycomm%lead .or. size(send, dim=${RANK}$) == mycomm%size) + #:if HASLENGTH + @:ASSERT(.not. mycomm%lead .or. len(send) == len(recv)) + #:endif + + call getoptarg(mycomm%leadrank, root0, root) + if (mycomm%rank == root0) then + if (present(displs)) then + @:ASSERT(size(displs) == mycomm%size) + allocate(displs0(mycomm%size)) + displs0(:) = displs + else + allocate(displs0(mycomm%size)) + displs0(1) = 0 + do ii = 2, mycomm%size + displs0(ii) = displs0(ii-1) + sendcounts(ii-1) + end do + end if + end if + + call mpi_scatterv(send, sendcounts, displs0, ${MPITYPE}$, recv, ${COUNT}$, ${MPITYPE}$, root0,& + & mycomm%id, error0) + call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatterv_${SUFFIX}$", error) + + end subroutine mpifx_scatterv_${SUFFIX}$ + +#:enddef mpifx_scatterv_dr1_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK) + $:mpifx_scatterv_dr0_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + TYPE_ABBREVS[TYPE] + str(RANK - 1) + $:mpifx_scatterv_dr1_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:endfor +#:endfor + +end module mpifx_scatterv_module diff --git a/lib/mpifx_send.fpp b/lib/mpifx_send.fpp new file mode 100644 index 0000000..fc775dd --- /dev/null +++ b/lib/mpifx_send.fpp @@ -0,0 +1,105 @@ +#:include 'mpifx.fypp' +#:set RANKS = range(MAX_RANK + 1) +#:set TYPES = ALL_TYPES + +!> Contains wrapper for \c MPI_SEND +module mpifx_send_module + use mpifx_common_module + implicit none + private + + public :: mpifx_send + + + !> Sends a message to a given node. + !! + !! \details All functions have the same argument list only differing in the + !! type and rank of the second argument. The second argument can be of + !! type integer (i), real (s), double precision (d), complex (c), + !! double complex (z), logical (b) and character (h). Its rank can vary from + !! zero (scalar) up to the maximum rank. + !! + !! \see MPI documentation (\c MPI_SEND) + !! + !! Example: + !! + !! program hello + !! use libmpifx_module + !! implicit none + !! + !! character(100) :: msg + !! type(mpifx) :: mycomm + !! integer :: source + !! + !! call mpifx_init() + !! call mycomm%init() + !! if (.not. mycomm%lead) then + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + !! call mpifx_send(mycomm, msg, mycomm%leadrank) + !! else + !! write(*, "(A)") "Lead node:" + !! do source = 1, mycomm%size - 1 + !! call mpifx_recv(mycomm, msg, source) + !! write(*,"(A,A)") "Message received: ", trim(msg) + !! end do + !! end if + !! call mpifx_finalize() + !! + !! end program hello + !! + interface mpifx_send +#:for TYPE in TYPES + #:for RANK in RANKS + module procedure mpifx_send_${TYPE_ABBREVS[TYPE]}$${RANK}$ + #:endfor +#:endfor + end interface mpifx_send + +contains + +#:def mpifx_send_template(SUFFIX, TYPE, MPITYPE, RANK, HASLENGTH) + + !> Sends a message to a given process. + !! \param mycomm MPI descriptor. + !! \param msg Msg to be sent. + !! \param dest Destination process. + !! \param tag Optional message tag (default: 0). + !! \param error Optional error handling flag. + !! + subroutine mpifx_send_${SUFFIX}$(mycomm, msg, dest, tag, error) + type(mpifx_comm), intent(in) :: mycomm + ${TYPE}$, intent(in) :: msg${RANKSUFFIX(RANK)}$ + integer, intent(in) :: dest + integer, intent(in), optional :: tag + integer, intent(out), optional :: error + + integer :: tag0, error0 + + #:set SIZE = '1' if RANK == 0 else 'size(msg)' + #:set COUNT = ('len(msg) * ' + SIZE if HASLENGTH else SIZE) + + call getoptarg(default_tag, tag0, tag) + call mpi_send(msg, ${COUNT}$, ${MPITYPE}$, dest, tag0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_SEND in mpifx_send_${SUFFIX}$", error) + + end subroutine mpifx_send_${SUFFIX}$ + +#:enddef mpifx_send_template + + +#:for TYPE in TYPES + #:for RANK in RANKS + + #:set FTYPE = FORTRAN_TYPES[TYPE] + #:set MPITYPE = MPI_TYPES[TYPE] + #:set HASLENGTH = HAS_LENGTH[TYPE] + #:set SUFFIX = TYPE_ABBREVS[TYPE] + str(RANK) + + $:mpifx_send_template(SUFFIX, FTYPE, MPITYPE, RANK, HASLENGTH) + + #:endfor +#:endfor + + + +end module mpifx_send_module diff --git a/make.arch.template b/make.arch.template deleted file mode 100644 index d04379f..0000000 --- a/make.arch.template +++ /dev/null @@ -1,21 +0,0 @@ -############################################################################ -# Architecture dependent makefile settings -############################################################################ - -# Fortran 2003 compiler -FXX = mpif90 - -# Fortran compiler otions -FXXOPT = -assume realloc_lhs -stand f03 -warn - -# Linker -LN = $(FXX) - -# Linker options -LNOPT = - -# M4 interpreter -M4 = m4 - -# M4 interpreter options -M4OPT = "" diff --git a/src/GNUmakefile b/src/GNUmakefile deleted file mode 100644 index 4ebc54f..0000000 --- a/src/GNUmakefile +++ /dev/null @@ -1,23 +0,0 @@ -############################################################################ -# -# Makefile to build the library. -# -# Edit "../make.arch" to adapt it to your system. -# -############################################################################ - -include ../make.arch - -libmpifx.a: - $(MAKE) \ - FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ - LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="$(M4OPT)" \ - -f Makefile.lib - -.PHONY: clean realclean -clean: - $(MAKE) -f Makefile.lib clean - -realclean: clean - $(MAKE) -f Makefile.lib realclean diff --git a/src/Makefile.lib b/src/Makefile.lib deleted file mode 100644 index 870580f..0000000 --- a/src/Makefile.lib +++ /dev/null @@ -1,59 +0,0 @@ -############################################################################### -# -# Library makefile -# -# Needs following variables: -# FXX: Fortran 2003 compiler -# FXXOPT: Options for the Fortran 2003 compiler -# M4: M4 macro processor -# M4OPT: Options for the M4 macro processor. You should use the -I option -# with this directory, if you are invoking the makefile from somewhere -# else. -# VPATH: The path to this directory, if you invoke the makefile from -# somewhere else. -# -############################################################################### - -.SUFFIXES: -.SUFFIXES: .f90 .F90 .o - -FILENAMES = libmpifx mpifx_comm mpifx_common mpifx_barrier mpifx_bcast \ - mpifx_send_recv mpifx_abort mpifx_init mpifx_finalize -TARGETLIB = libmpifx.a - -$(TARGETLIB): $(patsubst %,%.o,$(FILENAMES)) - ar r $@ $^ - -%.f90: %.F90 - $(M4) $(M4OPT) $< > $@ - -%.o: %.f90 - $(FXX) $(FXXOPT) -c $< - - -.PHONY: clean realclean -clean: - rm -f $(patsubst %,%.o,$(FILENAMES)) - rm -f $(patsubst %,%.f90,$(FILENAMES)) - -realclean: clean - rm -f $(patsubst %,%_module.mod,$(FILENAMES)) - rm -f $(TARGETLIB) - - -# Explicit dependencies -libmpifx.o: mpifx_comm.o mpifx_bcast.o mpifx_barrier.o mpifx_send_recv.o \ - mpifx_abort.o mpifx_init.o mpifx_finalize.o -mpifx_comm.o: mpifx_common.o -mpifx_common.o: -mpifx_barrier.o: mpifx_comm.o mpifx_common.o -mpifx_bcast.o: mpifx_comm.o mpifx_common.o -mpifx_send_recv.o: mpifx_comm.o mpifx_common.o -mpifx_abort.o: mpifx_comm.o mpifx_common.o -mpifx_init.o: mpifx_common.o -mpifx_finalize.o: mpifx_common.o - - -### Local Variables: -### mode:makefile -### End: diff --git a/src/common.m4 b/src/common.m4 deleted file mode 100644 index 7d3332c..0000000 --- a/src/common.m4 +++ /dev/null @@ -1,28 +0,0 @@ -dnl -dnl Undefining some M4 builtins to avoid conflicts with Fortran code -dnl invoke them via the builtin() command if needed. -dnl -undefine(`len')dnl -undefine(`index')dnl -undefine(`shift')dnl - - -dnl Sets a variable ($1) to the value of an optional argument ($2) -dnl if present or to a default value ($3) otherwise. -dnl -define(`_handle_inoptflag',`dnl -if (present($2)) then - $1 = $2 -else - $1 = $3 -end if -') - - -dnl Sets an optional output argument ($1) if present to a certain value ($2). -dnl -define(`_handle_outoptflag', `dnl -if (present($1)) then - $1 = $2 -end if -') diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 deleted file mode 100644 index 78f984a..0000000 --- a/src/libmpifx.F90 +++ /dev/null @@ -1,15 +0,0 @@ -!> \mainpage Fortran 2003 wrappers around MPI routines -!! -module libmpifx_module - use mpifx_comm_module - use mpifx_bcast_module - use mpifx_send_recv_module - use mpifx_barrier_module - use mpifx_abort_module - use mpifx_init_module - use mpifx_finalize_module - implicit none - - public - -end module libmpifx_module diff --git a/src/mpifx_abort.F90 b/src/mpifx_abort.F90 deleted file mode 100644 index 8b8a4e1..0000000 --- a/src/mpifx_abort.F90 +++ /dev/null @@ -1,32 +0,0 @@ -include(mpifx_abort.m4) - -module mpifx_abort_module - use mpifx_common_module - use mpifx_comm_module - implicit none - private - - public :: mpifx_abort - -contains - - !> Aborts MPI processes for the given communicator. - !! \param mympi MPI handler. - !! \param errorcode Exit error code for the operating system. (default: -1) - !! \param error Optional error flag. - !! - subroutine mpifx_abort(mympi, errorcode, error) - type(mpifx_comm), intent(in) :: mympi - integer, intent(in), optional :: errorcode - integer, intent(out), optional :: error - - integer :: error0, errorcode0 - - _handle_inoptflag(errorcode0, errorcode, -1) - call mpi_abort(mympi%id, errorcode0, error0) - call handle_errorflag(error0, "MPI_ABORT in mpifx_abort", error) - - end subroutine mpifx_abort - - -end module mpifx_abort_module diff --git a/src/mpifx_abort.m4 b/src/mpifx_abort.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpifx_abort.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_barrier.F90 b/src/mpifx_barrier.F90 deleted file mode 100644 index 65e1452..0000000 --- a/src/mpifx_barrier.F90 +++ /dev/null @@ -1,28 +0,0 @@ -include(mpifx_barrier.m4) - -module mpifx_barrier_module - use mpifx_common_module - use mpifx_comm_module - implicit none - private - - public :: mpifx_barrier - -contains - - !> Sets a barrier. - !! \param mympi MPI handler. - !! \param error Optional error flag. - subroutine mpifx_barrier(mympi, error) - type(mpifx_comm), intent(in) :: mympi - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_barrier(mympi%id, error0) - call handle_errorflag(error0, "MPI_BARRIER in mpifx_barrier", error) - - end subroutine mpifx_barrier - - -end module mpifx_barrier_module diff --git a/src/mpifx_barrier.m4 b/src/mpifx_barrier.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpifx_barrier.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_bcast.F90 b/src/mpifx_bcast.F90 deleted file mode 100644 index ed79866..0000000 --- a/src/mpifx_bcast.F90 +++ /dev/null @@ -1,135 +0,0 @@ -include(mpifx_bcast.m4) - -!> Fortran 2003 wrapper for MPI_BCAST. -!! -!! Example: -!! -!! program test_bcast -!! use libmpifx_module -!! -!! type(mpifx) :: mympi -!! integer :: buffer(3) -!! -!! call mympi%init() -!! if (mympi%master) then -!! buffer(:) = [ 1, 2, 3 ] -!! end if -!! call mpifx_bcast(mympi, buffer) -!! print "(A,I2.2,A,3I5)", "BUFFER:", mympi%iproc, ":", buffer -!! call mympi%destruct() -!! -!! end program test_bcast -!! -module mpifx_bcast_module - use mpifx_common_module - use mpifx_comm_module - implicit none - private - - public :: mpifx_bcast - - !> Broadcasts an MPI message to all nodes. - !! - !! \details All functions have the same argument list only differing in the - !! type and rank of the second argument. The second argument can be of - !! type integer (i), real (s) and double precision (d), complex (c) and - !! double complex (z), logical (l) and character (h). It can be a scalar - !! or an array of rank one to six. - !! - !! \see MPI documentation (routine mpi_bcast) - !! - interface mpifx_bcast - module procedure mpifx_bcast_i0, mpifx_bcast_i1, mpifx_bcast_i2, & - & mpifx_bcast_i3, mpifx_bcast_i4, mpifx_bcast_i5, mpifx_bcast_i6 - module procedure mpifx_bcast_s0, mpifx_bcast_s1, mpifx_bcast_s2, & - & mpifx_bcast_s3, mpifx_bcast_s4, mpifx_bcast_s5, mpifx_bcast_s6 - module procedure mpifx_bcast_d0, mpifx_bcast_d1, mpifx_bcast_d2, & - & mpifx_bcast_d3, mpifx_bcast_d4, mpifx_bcast_d5, mpifx_bcast_d6 - module procedure mpifx_bcast_c0, mpifx_bcast_c1, mpifx_bcast_c2, & - & mpifx_bcast_c3, mpifx_bcast_c4, mpifx_bcast_c5, mpifx_bcast_c6 - module procedure mpifx_bcast_z0, mpifx_bcast_z1, mpifx_bcast_z2, & - & mpifx_bcast_z3, mpifx_bcast_z4, mpifx_bcast_z5, mpifx_bcast_z6 - module procedure mpifx_bcast_l0, mpifx_bcast_l1, mpifx_bcast_l2, & - & mpifx_bcast_l3, mpifx_bcast_l4, mpifx_bcast_l5, mpifx_bcast_l6 - module procedure mpifx_bcast_h0, mpifx_bcast_h1, mpifx_bcast_h2, & - & mpifx_bcast_h3, mpifx_bcast_h4, mpifx_bcast_h5, mpifx_bcast_h6 - end interface - -contains - - _subroutine_mpifx_bcast(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_bcast(i1, integer, (:), size(msg), MPI_INTEGER) - _subroutine_mpifx_bcast(i2, integer, (:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_bcast(i3, integer, (:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_bcast(i4, integer, (:,:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_bcast(i5, integer, (:,:,:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_bcast(i6, integer, (:,:,:,:,:,:), size(msg), MPI_INTEGER) - - _subroutine_mpifx_bcast(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_bcast(s1, real(sp), (:), size(msg), MPI_REAL) - _subroutine_mpifx_bcast(s2, real(sp), (:,:), size(msg), MPI_REAL) - _subroutine_mpifx_bcast(s3, real(sp), (:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_bcast(s4, real(sp), (:,:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_bcast(s5, real(sp), (:,:,:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_bcast(s6, real(sp), (:,:,:,:,:,:), size(msg), MPI_REAL) - - _subroutine_mpifx_bcast(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_bcast(d1, real(dp), (:), size(msg), MPI_DOUBLE_PRECISION) - _subroutine_mpifx_bcast(d2, real(dp), (:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_bcast(d3, real(dp), (:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_bcast(d4, real(dp), (:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_bcast(d5, real(dp), (:,:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_bcast(d6, real(dp), (:,:,:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_bcast(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_bcast(c1, complex(sp), (:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_bcast(c2, complex(sp), (:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_bcast(c3, complex(sp), (:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_bcast(c4, complex(sp), (:,:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_bcast(c5, complex(sp), (:,:,:,:,:), size(msg), - MPI_COMPLEX) - _subroutine_mpifx_bcast(c6, complex(sp), (:,:,:,:,:,:), size(msg), - MPI_COMPLEX) - - _subroutine_mpifx_bcast(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_bcast(z1, complex(dp), (:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_bcast(z2, complex(dp), (:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_bcast(z3, complex(dp), (:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_bcast(z4, complex(dp), (:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_bcast(z5, complex(dp), (:,:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_bcast(z6, complex(dp), (:,:,:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_bcast(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_bcast(l1, logical, (:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_bcast(l2, logical, (:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_bcast(l3, logical, (:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_bcast(l4, logical, (:,:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_bcast(l5, logical, (:,:,:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_bcast(l6, logical, (:,:,:,:,:,:), size(msg), MPI_LOGICAL) - - _subroutine_mpifx_bcast(h0, character(*), , len(msg), MPI_CHARACTER) - _subroutine_mpifx_bcast(h1, character(*), (:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_bcast(h2, character(*), (:,:), - size(msg) * len(msg), MPI_CHARACTER) - _subroutine_mpifx_bcast(h3, character(*), (:,:,:), - size(msg) * len(msg), MPI_CHARACTER) - _subroutine_mpifx_bcast(h4, character(*), (:,:,:,:), - size(msg) * len(msg), MPI_CHARACTER) - _subroutine_mpifx_bcast(h5, character(*), (:,:,:,:,:), - size(msg) * len(msg), MPI_CHARACTER) - _subroutine_mpifx_bcast(h6, character(*), (:,:,:,:,:,:), - size(msg) * len(msg), MPI_CHARACTER) - -end module mpifx_bcast_module diff --git a/src/mpifx_bcast.m4 b/src/mpifx_bcast.m4 deleted file mode 100644 index c3be7d8..0000000 --- a/src/mpifx_bcast.m4 +++ /dev/null @@ -1,33 +0,0 @@ -include(common.m4) - -dnl ************************************************************************ -dnl *** bcast -dnl ************************************************************************ - -define(`_subroutine_mpifx_bcast',`dnl -dnl $1: subroutine suffix -dnl $2: dummy arguments type -dnl $3: dummy arguments rank specifier ("", (:), (:,:), etc.) -dnl $4: dummy arguments size (1 or size(dummyname)) -dnl $5: corresponding MPI type -!> Broadcasts an MPI message to all nodes (type $1). -!! \param mympi MPI descriptor -!! \param msg Msg to be broadcasted on root and received on non-root -!! nodes. -!! \param root Root node for the broadcast (default: mympi%imaster). -!! \param error Optional error handling flag. -!! -subroutine mpifx_bcast_$1(mympi, msg, root, error) - type(mpifx_comm), intent(in) :: mympi - $2 :: msg$3 - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _handle_inoptflag(root0, root, mympi%imaster) - call mpi_bcast(msg, $4, $5, root0, mympi%id, error0) - call handle_errorflag(error0, "MPI_BCAST in mpifx_bcast_$1", error) - -end subroutine mpifx_bcast_$1 -') diff --git a/src/mpifx_comm.F90 b/src/mpifx_comm.F90 deleted file mode 100644 index b1734a9..0000000 --- a/src/mpifx_comm.F90 +++ /dev/null @@ -1,53 +0,0 @@ -include(mpifx_comm.m4) - -module mpifx_comm_module - use mpifx_common_module - implicit none - private - - public :: mpifx_comm - - !> MPI communicator with some additional information. - type mpifx_comm - integer :: id !< Communicator id. - integer :: nproc !< Nr. of processes (size). - integer :: iproc !< Index (rank) of the current process. - integer :: imaster !< Index of the master node. - logical :: master !< True if current process is the master (rank == 0). - contains - !> Initializes the MPI environment. - procedure :: init => mpifx_comm_init - - end type mpifx_comm - -contains - - !> Initializes a communicator to contain all processes. - !! - !! \param self MPI Communicator. - !! \param error Error flag on return containing the first error occuring - !! during the calls mpi_comm_size and mpi_comm_rank. - !! - subroutine mpifx_comm_init(self, error) - class(mpifx_comm), intent(out) :: self - integer, intent(out), optional :: error - - integer :: error0 - - self%id = default_communicator - call mpi_comm_size(self%id, self%nproc, error0) - call handle_errorflag(error0, "mpi_comm_size() in mpifx_comm_init()", error) - if (error0 /= 0) then - return - end if - call mpi_comm_rank(self%id, self%iproc, error0) - call handle_errorflag(error0, "mpi_comm_rank() in mpifx_comm_init()", error) - if (error0 /= 0) then - return - end if - self%imaster = 0 - self%master = (self%iproc == self%imaster) - - end subroutine mpifx_comm_init - -end module mpifx_comm_module diff --git a/src/mpifx_comm.m4 b/src/mpifx_comm.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpifx_comm.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_common.F90 b/src/mpifx_common.F90 deleted file mode 100644 index 9e160f5..0000000 --- a/src/mpifx_common.F90 +++ /dev/null @@ -1,43 +0,0 @@ -include(mpifx_common.m4) - -!> Common helper routines. -!! \cond HIDDEN -module mpifx_common_module - use mpi ! Must be provided by the MPI framework - public - - integer, parameter :: default_tag = 0 - integer, parameter :: default_communicator = MPI_COMM_WORLD - integer, parameter :: sp = kind(1.0) - integer, parameter :: dp = kind(1.0d0) - -contains - - !> Handles optional error flag. - !! - !! \param error0 Error flag as returned by some routine. - !! \param msg Msg to print out, if program is stopped. - !! \param error Optional error flag. If present, error0 is passed to it, - !! otherwise if error0 was not zero, the error message in msg is printed - !! and the program is stopped. - !! - subroutine handle_errorflag(error0, msg, error) - integer, intent(in) :: error0 - character(*), intent(in) :: msg - integer, intent(out), optional :: error - - if (present(error)) then - error = error0 - elseif (error0 /= 0) then - write(*, "(A)") "Operation failed!" - write(*, "(A)") msg - write(*, "(A,I0)") "Error: ", error0 - stop - end if - - end subroutine handle_errorflag - - -end module mpifx_common_module - -!> \endcond diff --git a/src/mpifx_common.m4 b/src/mpifx_common.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpifx_common.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_finalize.F90 b/src/mpifx_finalize.F90 deleted file mode 100644 index 7e46e8c..0000000 --- a/src/mpifx_finalize.F90 +++ /dev/null @@ -1,23 +0,0 @@ -include(mpifx_finalize.m4) - -module mpifx_finalize_module - use mpifx_common_module - implicit none - private - - public :: mpifx_finalize - -contains - - subroutine mpifx_finalize(error) - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_finalize(error0) - call handle_errorflag(error0, "Error: mpi_finalize() in mpifx_finalize()", & - & error) - - end subroutine mpifx_finalize - -end module mpifx_finalize_module diff --git a/src/mpifx_finalize.m4 b/src/mpifx_finalize.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpifx_finalize.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_init.F90 b/src/mpifx_init.F90 deleted file mode 100644 index 068dd89..0000000 --- a/src/mpifx_init.F90 +++ /dev/null @@ -1,22 +0,0 @@ -include(mpifx_init.m4) - -module mpifx_init_module - use mpifx_common_module - implicit none - private - - public :: mpifx_init - -contains - - subroutine mpifx_init(error) - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_init(error0) - call handle_errorflag(error0, "Error: mpi_init() in mpifx_init()", error) - - end subroutine mpifx_init - -end module mpifx_init_module diff --git a/src/mpifx_init.m4 b/src/mpifx_init.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpifx_init.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_send_recv.F90 b/src/mpifx_send_recv.F90 deleted file mode 100644 index 1e61fc3..0000000 --- a/src/mpifx_send_recv.F90 +++ /dev/null @@ -1,253 +0,0 @@ -include(mpifx_send_recv.m4) - -!> Fortran 2003 wrappers for MPI_SEND and MPI_RECV -!! -!! \details High level wrappers for the MPI_SEND and MPI_RECV routines. Data -!! type and data count communicator must not be specified in the calls. -!! -!! Example: -!! -!! program hello -!! use libmpifx_module -!! implicit none -!! -!! character(100) :: msg -!! type(mpifx) :: mympi -!! integer :: source -!! -!! call mympi%init() -!! if (.not. mympi%master) then -!! write(msg, "(A,I0,A)") "Hello from process ", mympi%iproc, "!" -!! call mpifx_send(mympi, msg, mympi%imaster) -!! else -!! write(*, "(A)") "Master node:" -!! do source = 1, mympi%nproc - 1 -!! call mpifx_recv(mympi, msg, source) -!! write(*,"(A,A)") "Message received: ", trim(msg) -!! end do -!! end if -!! call mympi%destruct() -!! -module mpifx_send_recv_module - use mpifx_common_module - use mpifx_comm_module - implicit none - private - - public :: mpifx_send, mpifx_recv - - - !> Sends a message to a given node. - !! - !! \details All functions have the same argument list only differing in the - !! type and rank of the second argument. The second argument can be of - !! type integer (i), single (s) and double precision (d), single (c) and - !! double complex (z), logical (b) and character (h). It can be a scalar - !! or an array of rank one to six. - !! - !! \see MPI documentation (routine mpi_send) - !! - interface mpifx_send - module procedure mpifx_send_i0, mpifx_send_i1, mpifx_send_i2, & - & mpifx_send_i3, mpifx_send_i4, mpifx_send_i5, mpifx_send_i6 - module procedure mpifx_send_l0, mpifx_send_l1, mpifx_send_l2, & - & mpifx_send_l3, mpifx_send_l4, mpifx_send_l5, mpifx_send_l6 - module procedure mpifx_send_s0, mpifx_send_s1, mpifx_send_s2, & - & mpifx_send_s3, mpifx_send_s4, mpifx_send_s5, mpifx_send_s6 - module procedure mpifx_send_d0, mpifx_send_d1, mpifx_send_d2, & - & mpifx_send_d3, mpifx_send_d4, mpifx_send_d5, mpifx_send_d6 - module procedure mpifx_send_c0, mpifx_send_c1, mpifx_send_c2, & - & mpifx_send_c3, mpifx_send_c4, mpifx_send_c5, mpifx_send_c6 - module procedure mpifx_send_z0, mpifx_send_z1, mpifx_send_z2, & - & mpifx_send_z3, mpifx_send_z4, mpifx_send_z5, mpifx_send_z6 - module procedure mpifx_send_h0, mpifx_send_h1, mpifx_send_h2, & - & mpifx_send_h3, mpifx_send_h4, mpifx_send_h5, mpifx_send_h6 - end interface mpifx_send - - - !> Receives a message from a given node. - !! - !! \details All functions have the same argument list only differing in the - !! type and rank of the second argument. The second argument can be of - !! type integer (i), single (s) and double precision (d), single (c) and - !! double complex (z), logical (b) and character (h). It can be a scalar - !! or an array of rank one to six. - !! - !! \see MPI documentation (routine mpi_recv) - !! - interface mpifx_recv - module procedure mpifx_recv_i0, mpifx_recv_i1, mpifx_recv_i2, & - & mpifx_recv_i3, mpifx_recv_i4, mpifx_recv_i5, mpifx_recv_i6 - module procedure mpifx_recv_l0, mpifx_recv_l1, mpifx_recv_l2, & - & mpifx_recv_l3, mpifx_recv_l4, mpifx_recv_l5, mpifx_recv_l6 - module procedure mpifx_recv_s0, mpifx_recv_s1, mpifx_recv_s2, & - & mpifx_recv_s3, mpifx_recv_s4, mpifx_recv_s5, mpifx_recv_s6 - module procedure mpifx_recv_d0, mpifx_recv_d1, mpifx_recv_d2, & - & mpifx_recv_d3, mpifx_recv_d4, mpifx_recv_d5, mpifx_recv_d6 - module procedure mpifx_recv_c0, mpifx_recv_c1, mpifx_recv_c2, & - & mpifx_recv_c3, mpifx_recv_c4, mpifx_recv_c5, mpifx_recv_c6 - module procedure mpifx_recv_z0, mpifx_recv_z1, mpifx_recv_z2, & - & mpifx_recv_z3, mpifx_recv_z4, mpifx_recv_z5, mpifx_recv_z6 - module procedure mpifx_recv_h0, mpifx_recv_h1, mpifx_recv_h2, & - & mpifx_recv_h3, mpifx_recv_h4, mpifx_recv_h5, mpifx_recv_h6 - end interface mpifx_recv - - -contains - - _subroutine_mpifx_send(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_send(i1, integer, (:), size(msg), MPI_INTEGER) - _subroutine_mpifx_send(i2, integer, (:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_send(i3, integer, (:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_send(i4, integer, (:,:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_send(i5, integer, (:,:,:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_send(i6, integer, (:,:,:,:,:,:), size(msg), MPI_INTEGER) - - _subroutine_mpifx_send(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_send(l1, logical, (:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_send(l2, logical, (:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_send(l3, logical, (:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_send(l4, logical, (:,:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_send(l5, logical, (:,:,:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_send(l6, logical, (:,:,:,:,:,:), size(msg), MPI_LOGICAL) - - _subroutine_mpifx_send(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_send(s1, real(sp), (:), size(msg), MPI_REAL) - _subroutine_mpifx_send(s2, real(sp), (:,:), size(msg), MPI_REAL) - _subroutine_mpifx_send(s3, real(sp), (:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_send(s4, real(sp), (:,:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_send(s5, real(sp), (:,:,:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_send(s6, real(sp), (:,:,:,:,:,:), size(msg), MPI_REAL) - - _subroutine_mpifx_send(d0, real(dp), , 1, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_send(d1, real(dp), (:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_send(d2, real(dp), (:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_send(d3, real(dp), (:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_send(d4, real(dp), (:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_send(d5, real(dp), (:,:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_send(d6, real(dp), (:,:,:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_send(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_send(c1, complex(sp), (:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_send(c2, complex(sp), (:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_send(c3, complex(sp), (:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_send(c4, complex(sp), (:,:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_send(c5, complex(sp), (:,:,:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_send(c6, complex(sp), (:,:,:,:,:,:), size(msg), MPI_COMPLEX) - - _subroutine_mpifx_send(z0, complex(dp), , 1, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_send(z1, complex(dp), (:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_send(z2, complex(dp), (:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_send(z3, complex(dp), (:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_send(z4, complex(dp), (:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_send(z5, complex(dp), (:,:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_send(z6, complex(dp), (:,:,:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_send(h0, character(*), , len(msg), - MPI_CHARACTER) - _subroutine_mpifx_send(h1, character(*), (:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_send(h2, character(*), (:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_send(h3, character(*), (:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_send(h4, character(*), (:,:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_send(h5, character(*), (:,:,:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_send(h6, character(*), (:,:,:,:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - - - _subroutine_mpifx_recv(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_recv(i1, integer, (:), size(msg), MPI_INTEGER) - _subroutine_mpifx_recv(i2, integer, (:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_recv(i3, integer, (:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_recv(i4, integer, (:,:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_recv(i5, integer, (:,:,:,:,:), size(msg), MPI_INTEGER) - _subroutine_mpifx_recv(i6, integer, (:,:,:,:,:,:), size(msg), MPI_INTEGER) - - _subroutine_mpifx_recv(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_recv(l1, logical, (:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_recv(l2, logical, (:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_recv(l3, logical, (:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_recv(l4, logical, (:,:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_recv(l5, logical, (:,:,:,:,:), size(msg), MPI_LOGICAL) - _subroutine_mpifx_recv(l6, logical, (:,:,:,:,:,:), size(msg), MPI_LOGICAL) - - _subroutine_mpifx_recv(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_recv(s1, real(sp), (:), size(msg), MPI_REAL) - _subroutine_mpifx_recv(s2, real(sp), (:,:), size(msg), MPI_REAL) - _subroutine_mpifx_recv(s3, real(sp), (:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_recv(s4, real(sp), (:,:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_recv(s5, real(sp), (:,:,:,:,:), size(msg), MPI_REAL) - _subroutine_mpifx_recv(s6, real(sp), (:,:,:,:,:,:), size(msg), MPI_REAL) - - _subroutine_mpifx_recv(d0, real(dp), , 1, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_recv(d1, real(dp), (:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_recv(d2, real(dp), (:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_recv(d3, real(dp), (:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_recv(d4, real(dp), (:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_recv(d5, real(dp), (:,:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_recv(d6, real(dp), (:,:,:,:,:,:), size(msg), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_recv(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_recv(c1, complex(sp), (:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_recv(c2, complex(sp), (:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_recv(c3, complex(sp), (:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_recv(c4, complex(sp), (:,:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_recv(c5, complex(sp), (:,:,:,:,:), size(msg), MPI_COMPLEX) - _subroutine_mpifx_recv(c6, complex(sp), (:,:,:,:,:,:), size(msg), MPI_COMPLEX) - - _subroutine_mpifx_recv(z0, complex(dp), , 1, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_recv(z1, complex(dp), (:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_recv(z2, complex(dp), (:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_recv(z3, complex(dp), (:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_recv(z4, complex(dp), (:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_recv(z5, complex(dp), (:,:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_recv(z6, complex(dp), (:,:,:,:,:,:), size(msg), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_recv(h0, character(*), , len(msg), - MPI_CHARACTER) - _subroutine_mpifx_recv(h1, character(*), (:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_recv(h2, character(*), (:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_recv(h3, character(*), (:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_recv(h4, character(*), (:,:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_recv(h5, character(*), (:,:,:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - _subroutine_mpifx_recv(h6, character(*), (:,:,:,:,:,:), size(msg) * len(msg), - MPI_CHARACTER) - -end module mpifx_send_recv_module diff --git a/src/mpifx_send_recv.m4 b/src/mpifx_send_recv.m4 deleted file mode 100644 index d460361..0000000 --- a/src/mpifx_send_recv.m4 +++ /dev/null @@ -1,72 +0,0 @@ -include(common.m4) - -dnl ************************************************************************ -dnl *** send -dnl ************************************************************************ - -define(`_subroutine_mpifx_send', `dnl -dnl $1: subroutien suffix -dnl $2: dummy arguments type -dnl $3: dummy arguments rank specifier ("", (:), (:,:), etc.) -dnl $4: dummy arguments size (1 or len(msg) or size(msg)) -dnl $5: corresponding MPI type -!> Sends a message to a given process. -!! \param mympi MPI descriptor. -!! \param msg Msg to be sent. -!! \param dest Destination process. -!! \param tag Optional message tag (default: 0). -!! \param error Optional error handling flag. -!! -subroutine mpifx_send_$1(mympi, msg, dest, tag, error) - type(mpifx_comm), intent(in) :: mympi - $2, intent(in) :: msg$3 - integer, intent(in) :: dest - integer, intent(in), optional :: tag - integer, intent(out), optional :: error - - integer :: tag0, error0 - - _handle_inoptflag(tag0, tag, default_tag) - call mpi_send(msg, $4, $5, dest, tag0, mympi%id, error0) - call handle_errorflag(error0, "MPI_SEND in mpifx_send_$1", error) - -end subroutine mpifx_send_$1 -') - -dnl ************************************************************************ -dnl *** recv -dnl ************************************************************************ - -define(`_subroutine_mpifx_recv', `dnl -dnl $1: subroutien suffix -dnl $2: dummy arguments type -dnl $3: dummy arguments rank specifier ("", (:), (:,:), etc.) -dnl $4: dummy arguments size (1 or size(dummyname)) -dnl $5: corresponding MPI type -!> Receives a message from a given process. -!! \param mympi MPI descriptor. -!! \param msg Msg to be received. -!! \param source Optional source process (default: MPI_ANY_SOURCE) -!! \param tag Optional message tag (default: MPI_ANY_TAG). -!! \param status Optional status array. -!! \param error Optional error handling flag. -!! -subroutine mpifx_recv_$1(mympi, msg, source, tag, status, error) - type(mpifx_comm), intent(in) :: mympi - $2, intent(out) :: msg$3 - integer, intent(in), optional :: source, tag - integer, intent(out), optional :: status(MPI_STATUS_SIZE) - integer, intent(out), optional :: error - - integer :: source0, tag0, error0 - integer :: status0(MPI_STATUS_SIZE) - - _handle_inoptflag(tag0, tag, MPI_ANY_TAG) - _handle_inoptflag(source0, source, MPI_ANY_SOURCE) - call mpi_recv(msg, $4, $5, source0, tag0, mympi%id, status0, & - & error0) - call handle_errorflag(error0, "MPI_RECV in mpifx_recv_$1", error) - _handle_outoptflag(status, status0) - -end subroutine mpifx_recv_$1 -') diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt new file mode 100644 index 0000000..33983d7 --- /dev/null +++ b/test/CMakeLists.txt @@ -0,0 +1,16 @@ +set(targets + test_allgather + test_allgatherv + test_allreduce + test_bcast + test_comm_split + test_gather + test_gatherv + test_reduce + test_scatter + test_scatterv) + +foreach(target IN LISTS targets) + add_executable(${target} ${target}.f90) + target_link_libraries(${target} MpiFx) +endforeach() diff --git a/test/GNUmakefile b/test/GNUmakefile deleted file mode 100644 index a989786..0000000 --- a/test/GNUmakefile +++ /dev/null @@ -1,67 +0,0 @@ -############################################################################ -# -# Makefile to demonstrate, how to incorporate the library makefile from -# an external makefile by passing the appropriate variables. -# -# Edit "../make.arch" to adapt it to your system. -# -############################################################################ - -# Directory where library source can be found -SRCDIR_MPIFX = ../src - -include ../make.arch - - -############################################################################ -# Building the test programs. -# -# You can replace this part with your projects makefile. Make sure, that -# you introduce at least one dependency on the library file (see below). -############################################################################ - -.SUFFIXES: -.SUFFIXES: .f90 .F90 .o .m4 - -BINARIES = test_bcast test_send_recv - -all: $(BINARIES) - - -test_bcast: test_bcast.o - $(LN) $(LNOPT) -o $@ $^ -L./ -lmpifx - -test_send_recv: test_send_recv.o - $(LN) $(LNOPT) -o $@ $^ -L./ -lmpifx - - - -%.o: %.f90 - $(FXX) $(FXXOPT) -c $< - -.PHONY: clean realclean -clean: - $(MAKE) -f $(SRCDIR_MPIFX)/Makefile.lib clean - rm -f *.mod *.o - -realclean: clean - $(MAKE) -f $(SRCDIR_MPIFX)/Makefile.lib realclean - rm -f $(BINARIES) - - -# Dependencies: test programs can only be compiled after library is done as -# the compiler needs the .mod files -test_bcast.o: libmpifx.a -test_send_recv: libmpifx.a - - -############################################################################ -# Invoking the makefile of the library to build it in place. -############################################################################ -libmpifx.a: - $(MAKE) \ - FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ - LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="-I $(SRCDIR_MPIFX) $(M4OPT)" \ - VPATH="$(SRCDIR_MPIFX)" \ - -f "$(SRCDIR_MPIFX)/Makefile.lib" diff --git a/test/integration/cmake/CMakeLists.txt b/test/integration/cmake/CMakeLists.txt new file mode 100644 index 0000000..a1be0f3 --- /dev/null +++ b/test/integration/cmake/CMakeLists.txt @@ -0,0 +1,8 @@ +cmake_minimum_required(VERSION 3.16) + +project(TestMpiFxBuild LANGUAGES Fortran) + +find_package(MpiFx REQUIRED) + +add_executable(test_mpifxbuild test_mpifxbuild.f90) +target_link_libraries(test_mpifxbuild MpiFx::MpiFx) diff --git a/test/integration/cmake/runtest.sh b/test/integration/cmake/runtest.sh new file mode 100755 index 0000000..7216511 --- /dev/null +++ b/test/integration/cmake/runtest.sh @@ -0,0 +1,26 @@ +#!/bin/bash +# +# Tests whether the installed MpiFx library can be used within a CMake project. +# +# Arguments: +# +# - building directory (will be created, should not exist) +# +# Requirements: +# +# - Environment variable FC contains the same Fortran compiler as used for MpiFx +# +# - Environment variable CMAKE_PREFIX_PATH contains the MpiFx install root. +# +SCRIPTDIR=$(dirname $0) +SCRIPTNAME=$(basename $0) +BUILDDIR=$1 + +if [ -d ${BUILDDIR} ]; then + echo "${SCRIPTNAME}: Test build directory '${BUILDDIR}' already exists." >&2 + exit 1 +fi + +FC=$FC cmake -B ${BUILDDIR} ${SCRIPTDIR} || { echo "Configuration step failed" >&2; exit 1; } +cmake --build ${BUILDDIR} -- VERBOSE=1 || { echo "Build step failed" >&2; exit 1; } +echo "CMake build succeeded!" diff --git a/test/integration/cmake/test_mpifxbuild.f90 b/test/integration/cmake/test_mpifxbuild.f90 new file mode 100644 index 0000000..af9b342 --- /dev/null +++ b/test/integration/cmake/test_mpifxbuild.f90 @@ -0,0 +1,5 @@ +program test_mpifxbuild + use libmpifx_module + implicit none + +end program test_mpifxbuild diff --git a/test/integration/pkgconfig/runtest.sh b/test/integration/pkgconfig/runtest.sh new file mode 100755 index 0000000..f6ad9a8 --- /dev/null +++ b/test/integration/pkgconfig/runtest.sh @@ -0,0 +1,45 @@ +#!/bin/bash +# +# Tests whether the installed MpiFx library can be used with pkg-config based builds. +# +# Arguments: +# +# - building directory (will be created if it does not exist) +# +# Requirements: +# +# - Environment variable FC contains the same Fortran compiler as used for MpiFx +# +# - Environment variable PKG_CONFIG_PATH contains the lib/pkgconfig folder within +# the installed MpiFx tree. +# +# - You pass all linker options as arguments, which are needed to link an MPI-binary +# with your compiler. Alternatively, you can specify the name of the MPI-wrapper +# as your Fortran compiler in FC. +# +SCRIPTDIR=$(dirname $0) +SCRIPTNAME=$(basename $0) +BUILDDIR=$1 +shift +CUSTOMLIBS=$* + +if [ ! -d ${BUILDDIR} ]; then + mkdir ${BUILDDIR} || { echo "Could not create build dir '${BUILDDIR}'" >&2; exit 1; } +fi + +# Make sure, scriptdir is absoulte +cd ${SCRIPTDIR} +SCRIPTDIR=${PWD} +cd - + +cd ${BUILDDIR} || { echo "Could not change to build dir '${BUILDDIR}'" >&2; exit 1; } +pkg-config --exists mpifx || { echo "No PKG-CONFIG found for MpiFx" >&2; exit 1; } + +cflags=$(pkg-config --cflags mpifx) +libs=$(pkg-config --libs mpifx) + +cmd="${FC} ${cflags} ${SCRIPTDIR}/test_mpifxbuild.f90 ${libs} ${CUSTOMLIBS}" + +echo "Build command: ${cmd}" +${cmd} || { echo "Build command failed" >&2; exit 1; } +echo "PKG-CONFIG build succeeded." diff --git a/test/integration/pkgconfig/test_mpifxbuild.f90 b/test/integration/pkgconfig/test_mpifxbuild.f90 new file mode 100644 index 0000000..d4e5ba0 --- /dev/null +++ b/test/integration/pkgconfig/test_mpifxbuild.f90 @@ -0,0 +1,72 @@ +program test_bcast + use libmpifx_module + implicit none + + integer, parameter :: dp = kind(1.0d0) + integer, parameter :: sp = kind(1.0) + + type(mpifx_comm) :: mycomm + integer :: buffer(3) + logical :: lbuffer(3) + real(dp) :: rbuffer(2, 2) + complex(sp) :: cbuffer + character(5) :: text + + ! Integer vector + call mpifx_init() + call mycomm%init() + buffer(:) = 0 + print "(A,I2.2,A,3I5)", "CHK01:", mycomm%rank, ":", buffer + if (mycomm%lead) then + buffer(:) = [ 1, 2, 3 ] + end if + print "(A,I2.2,A,3I5)", "CHK02:", mycomm%rank, ":", buffer + call mpifx_bcast(mycomm, buffer) + print "(A,I2.2,A,3I5)", "CHK03:", mycomm%rank, ":", buffer + call mpifx_barrier(mycomm) + + ! Logical vector + lbuffer(:) = .false. + print "(A,I2.2,A,3L5)", "CHK04:", mycomm%rank, ":", lbuffer + if (mycomm%lead) then + lbuffer(:) = [ .true., .false., .true. ] + end if + print "(A,I2.2,A,3L5)", "CHK05:", mycomm%rank, ":", lbuffer + call mpifx_bcast(mycomm, lbuffer) + print "(A,I2.2,A,3L5)", "CHK06:", mycomm%rank, ":", lbuffer + call mpifx_barrier(mycomm) + + ! Real rank 2 array + rbuffer(:,:) = 0.0_dp + print "(A,I2.2,A,4F10.6)", "CHK07:", mycomm%rank, ":", rbuffer + if (mycomm%lead) then + rbuffer(:,:) = reshape([ real(dp) :: 1, 2, 3, 4 ], [ 2, 2 ]) + end if + print "(A,I2.2,A,4F10.6)", "CHK08:", mycomm%rank, ":", rbuffer + call mpifx_bcast(mycomm, rbuffer) + print "(A,I2.2,A,4F10.6)", "CHK09:", mycomm%rank, ":", rbuffer + call mpifx_barrier(mycomm) + + ! Complex scalar + cbuffer = cmplx(0, 0, sp) + print "(A,I2.2,A,2F10.6)", "CHK10:", mycomm%rank, ":", cbuffer + if (mycomm%lead) then + cbuffer = cmplx(-1, 1, sp) + end if + print "(A,I2.2,A,2F10.6)", "CHK11:", mycomm%rank, ":", cbuffer + call mpifx_bcast(mycomm, cbuffer) + print "(A,I2.2,A,2F10.6)", "CHK12:", mycomm%rank, ":", cbuffer + + ! Character + text = " " + print "(A,I2.2,A,A6)", "CHK13:", mycomm%rank, ":", text + if (mycomm%lead) then + text = "hello" + end if + print "(A,I2.2,A,A6)", "CHK14:", mycomm%rank, ":", text + call mpifx_bcast(mycomm, text) + print "(A,I2.2,A,A6)", "CHK15:", mycomm%rank, ":", text + + call mpifx_finalize() + +end program test_bcast diff --git a/test/test_allgather.f90 b/test/test_allgather.f90 new file mode 100644 index 0000000..7b58d3e --- /dev/null +++ b/test/test_allgather.f90 @@ -0,0 +1,54 @@ +program test_allgather + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + integer :: send0 + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:), recv2(:,:) + character(100) :: formstr + character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + + call mpifx_init() + call mycomm%init() + + ! I0 -> I1 + send0 = mycomm%rank * 2 + allocate(recv1(1 * mycomm%size)) + recv1(:) = 0 + write(*, label // ",A,1X,I0)") 1, mycomm%rank, & + & "Send0 buffer:", send0 + call mpifx_allgather(mycomm, send0, recv1) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 2, mycomm%rank, & + & "Recv1 buffer:", recv1(:) + deallocate(recv1) + + ! I1 -> I1 + allocate(send1(2)) + allocate(recv1(size(send1) * mycomm%size)) + recv1(:) = 0 + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 3, mycomm%rank, & + & "Send1 buffer:", send1(:) + call mpifx_allgather(mycomm, send1, recv1) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 4, mycomm%rank, & + & "Recv1 buffer:", recv1 + + ! I1 -> I2 + allocate(recv2(size(send1), mycomm%size)) + recv2(:,:) = 0 + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 5, mycomm%rank, & + & "Send1 buffer:", send1(:) + call mpifx_allgather(mycomm, send1, recv2) + write(formstr, "(A,I0,A)") "A,", size(recv2), "(1X,I0))" + write(*, label // formstr) 6, mycomm%rank, & + & "Recv2 buffer:", recv2 + + call mpifx_finalize() + +end program test_allgather diff --git a/test/test_allgatherv.f90 b/test/test_allgatherv.f90 new file mode 100644 index 0000000..e3c831d --- /dev/null +++ b/test/test_allgatherv.f90 @@ -0,0 +1,87 @@ +program test_allgatherv + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: send1(:), send2(:,:) + real(sp), allocatable :: recv1(:), recv2(:,:) + real(sp) :: send0 + integer, allocatable :: recvcounts(:) + integer, allocatable :: displs(:) + integer :: ii, nrecv, nCol + character(100) :: formstr + character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + + call mpifx_init() + call mycomm%init() + + ! R1 -> R1 + if (mycomm%rank == mycomm%size - 1) then + write(*, *) 'Test gather rank=1 -> rank=1' + end if + allocate(send1(mycomm%rank+1)) + send1 = real(mycomm%rank+1, sp) + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv1(nrecv)) + allocate(recvcounts(mycomm%size)) + do ii = 1, mycomm%size + recvcounts(ii) = ii + end do + call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) + if (mycomm%rank == mycomm%size - 1) then + write(*, *) "Recv1 buffer:", recv1 + end if + deallocate(recvcounts) + deallocate(recv1) + + ! R2 -> R2 + if (mycomm%rank == mycomm%size - 1) then + write(*, *) + write(*, *) 'Test gather rank=2 -> rank=2' + end if + nCol = 5 + allocate(send2(nCol, mycomm%rank+1)) + send2 = real(mycomm%rank + 1, sp) + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv2(nCol, nrecv)) + recv2 = 0 + allocate(recvcounts(mycomm%size)) + do ii = 1, mycomm%size + recvcounts(ii) = nCol*ii + end do + call mpifx_allgatherv(mycomm, send2, recv2, recvcounts) + if (mycomm%rank == mycomm%size - 1) then + write(*, *) "Recv2 buffer:", shape(recv2) + do ii = 1, nrecv + write(*,*)recv2(:,ii) + end do + end if + deallocate(recvcounts) + + + ! R0 -> R1 with specified receive pattern + if (mycomm%rank == mycomm%size - 1) then + write(*, *) + write(*, *) 'Test gather scalar -> rank=1' + end if + send0 = real(mycomm%rank + 1, sp) + nrecv = mycomm%size + allocate(recv1(nrecv)) + allocate(recvcounts(mycomm%size)) + recvcounts = 1 + allocate(displs(mycomm%size)) + ! set a non trivial displs vector + do ii = 1, mycomm%size + displs(ii) = mycomm%size - ii + end do + call mpifx_allgatherv(mycomm, send0, recv1, recvcounts, displs) + if (mycomm%rank == mycomm%size - 1) then + write(*, *) "Recv1 buffer:", recv1 + end if + + call mpifx_finalize() + +end program test_allgatherv diff --git a/test/test_allreduce.f90 b/test/test_allreduce.f90 new file mode 100644 index 0000000..cfb9df8 --- /dev/null +++ b/test/test_allreduce.f90 @@ -0,0 +1,42 @@ +program test_allreduce + use libmpifx_module + implicit none + + integer, parameter :: dp = kind(1.0d0) + + type(mpifx_comm) :: mycomm + integer :: vali0, resvali0 + real(dp) :: valr(3), resvalr(3) + + call mpifx_init() + call mycomm%init() + + ! Reduction of a scalar + vali0 = mycomm%rank * 2 + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%rank, & + & "Value to be operated on:", vali0 + call mpifx_allreduce(mycomm, vali0, resvali0, MPI_SUM) + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%rank, & + & "Obtained result (sum):", resvali0 + + ! Reduction of an array + valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + & "Value to be operated on:", valr(:) + call mpifx_allreduce(mycomm, valr, resvalr, MPI_PROD) + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + & "Obtained result (prod):", resvalr(:) + + ! In place summation + resvalr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 5, mycomm%rank, & + & "Value to be operated on:", resvalr(:) + call mpifx_allreduceip(mycomm, resvalr, MPI_SUM) + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 6, mycomm%rank, & + & "Obtained result (sum):", resvalr(:) + + call mpifx_finalize() + +end program test_allreduce diff --git a/test/test_bcast.f90 b/test/test_bcast.f90 index 4888b3b..d4e5ba0 100644 --- a/test/test_bcast.f90 +++ b/test/test_bcast.f90 @@ -1,10 +1,11 @@ program test_bcast use libmpifx_module - + implicit none + integer, parameter :: dp = kind(1.0d0) integer, parameter :: sp = kind(1.0) - type(mpifx_comm) :: mympi + type(mpifx_comm) :: mycomm integer :: buffer(3) logical :: lbuffer(3) real(dp) :: rbuffer(2, 2) @@ -13,58 +14,58 @@ program test_bcast ! Integer vector call mpifx_init() - call mympi%init() + call mycomm%init() buffer(:) = 0 - print "(A,I2.2,A,3I5)", "CHK01:", mympi%iproc, ":", buffer - if (mympi%master) then + print "(A,I2.2,A,3I5)", "CHK01:", mycomm%rank, ":", buffer + if (mycomm%lead) then buffer(:) = [ 1, 2, 3 ] end if - print "(A,I2.2,A,3I5)", "CHK02:", mympi%iproc, ":", buffer - call mpifx_bcast(mympi, buffer) - print "(A,I2.2,A,3I5)", "CHK03:", mympi%iproc, ":", buffer - call mpifx_barrier(mympi) + print "(A,I2.2,A,3I5)", "CHK02:", mycomm%rank, ":", buffer + call mpifx_bcast(mycomm, buffer) + print "(A,I2.2,A,3I5)", "CHK03:", mycomm%rank, ":", buffer + call mpifx_barrier(mycomm) ! Logical vector lbuffer(:) = .false. - print "(A,I2.2,A,3L5)", "CHK04:", mympi%iproc, ":", lbuffer - if (mympi%master) then + print "(A,I2.2,A,3L5)", "CHK04:", mycomm%rank, ":", lbuffer + if (mycomm%lead) then lbuffer(:) = [ .true., .false., .true. ] end if - print "(A,I2.2,A,3L5)", "CHK05:", mympi%iproc, ":", lbuffer - call mpifx_bcast(mympi, lbuffer) - print "(A,I2.2,A,3L5)", "CHK06:", mympi%iproc, ":", lbuffer - call mpifx_barrier(mympi) + print "(A,I2.2,A,3L5)", "CHK05:", mycomm%rank, ":", lbuffer + call mpifx_bcast(mycomm, lbuffer) + print "(A,I2.2,A,3L5)", "CHK06:", mycomm%rank, ":", lbuffer + call mpifx_barrier(mycomm) ! Real rank 2 array rbuffer(:,:) = 0.0_dp - print "(A,I2.2,A,4F10.6)", "CHK07:", mympi%iproc, ":", rbuffer - if (mympi%master) then + print "(A,I2.2,A,4F10.6)", "CHK07:", mycomm%rank, ":", rbuffer + if (mycomm%lead) then rbuffer(:,:) = reshape([ real(dp) :: 1, 2, 3, 4 ], [ 2, 2 ]) end if - print "(A,I2.2,A,4F10.6)", "CHK08:", mympi%iproc, ":", rbuffer - call mpifx_bcast(mympi, rbuffer) - print "(A,I2.2,A,4F10.6)", "CHK09:", mympi%iproc, ":", rbuffer - call mpifx_barrier(mympi) + print "(A,I2.2,A,4F10.6)", "CHK08:", mycomm%rank, ":", rbuffer + call mpifx_bcast(mycomm, rbuffer) + print "(A,I2.2,A,4F10.6)", "CHK09:", mycomm%rank, ":", rbuffer + call mpifx_barrier(mycomm) ! Complex scalar cbuffer = cmplx(0, 0, sp) - print "(A,I2.2,A,2F10.6)", "CHK10:", mympi%iproc, ":", cbuffer - if (mympi%master) then + print "(A,I2.2,A,2F10.6)", "CHK10:", mycomm%rank, ":", cbuffer + if (mycomm%lead) then cbuffer = cmplx(-1, 1, sp) end if - print "(A,I2.2,A,2F10.6)", "CHK11:", mympi%iproc, ":", cbuffer - call mpifx_bcast(mympi, cbuffer) - print "(A,I2.2,A,2F10.6)", "CHK12:", mympi%iproc, ":", cbuffer + print "(A,I2.2,A,2F10.6)", "CHK11:", mycomm%rank, ":", cbuffer + call mpifx_bcast(mycomm, cbuffer) + print "(A,I2.2,A,2F10.6)", "CHK12:", mycomm%rank, ":", cbuffer ! Character text = " " - print "(A,I2.2,A,A6)", "CHK13:", mympi%iproc, ":", text - if (mympi%master) then + print "(A,I2.2,A,A6)", "CHK13:", mycomm%rank, ":", text + if (mycomm%lead) then text = "hello" end if - print "(A,I2.2,A,A6)", "CHK14:", mympi%iproc, ":", text - call mpifx_bcast(mympi, text) - print "(A,I2.2,A,A6)", "CHK15:", mympi%iproc, ":", text + print "(A,I2.2,A,A6)", "CHK14:", mycomm%rank, ":", text + call mpifx_bcast(mycomm, text) + print "(A,I2.2,A,A6)", "CHK15:", mycomm%rank, ":", text call mpifx_finalize() diff --git a/test/test_comm_split.f90 b/test/test_comm_split.f90 new file mode 100644 index 0000000..c4ff878 --- /dev/null +++ b/test/test_comm_split.f90 @@ -0,0 +1,17 @@ +program test_comm_split + use libmpifx_module + implicit none + + type(mpifx_comm) :: allproc, groupproc + integer :: groupsize, mygroup + + call mpifx_init() + call allproc%init() + groupsize = allproc%size / 2 + mygroup = allproc%rank / groupsize + call allproc%split(mygroup, allproc%rank, groupproc) + write(*, "(3(A,1X,I0,1X))") "GLOBAL ID:", allproc%rank, "SUBGROUP", & + & mygroup, "SUBGROUP ID", groupproc%rank + call mpifx_finalize() + +end program test_comm_split diff --git a/test/test_gather.f90 b/test/test_gather.f90 new file mode 100644 index 0000000..4badc84 --- /dev/null +++ b/test/test_gather.f90 @@ -0,0 +1,72 @@ +program test_gather + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + integer :: send0 + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:), recv2(:,:) + character(100) :: formstr + character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + + call mpifx_init() + call mycomm%init() + + ! I0 -> I1 + send0 = mycomm%rank * 2 ! Arbitrary number to send + if (mycomm%lead) then + allocate(recv1(1 * mycomm%size)) + recv1(:) = 0 + else + allocate(recv1(0)) + end if + write(*, label // ",A,1X,I0)") 1, mycomm%rank, & + & "Send0 buffer:", send0 + call mpifx_gather(mycomm, send0, recv1) + if (mycomm%lead) then + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 2, mycomm%rank, & + & "Recv1 buffer:", recv1(:) + end if + deallocate(recv1) + + ! I1 -> I1 + allocate(send1(2)) + if (mycomm%lead) then + allocate(recv1(size(send1) * mycomm%size)) + recv1(:) = 0 + else + allocate(recv1(0)) + end if + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers to send + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 3, mycomm%rank, & + & "Send1 buffer:", send1(:) + call mpifx_gather(mycomm, send1, recv1) + if (mycomm%lead) then + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 4, mycomm%rank, & + & "Recv1 buffer:", recv1 + end if + + ! I1 -> I2 + if (mycomm%lead) then + allocate(recv2(size(send1), mycomm%size)) + recv2(:,:) = 0 + else + allocate(recv2(0, 0)) + end if + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers to send + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 5, mycomm%rank, & + & "Send1 buffer:", send1(:) + call mpifx_gather(mycomm, send1, recv2) + if (mycomm%lead) then + write(formstr, "(A,I0,A)") "A,", size(recv2), "(1X,I0))" + write(*, label // formstr) 6, mycomm%rank, & + & "Recv2 buffer:", recv2 + end if + + call mpifx_finalize() + +end program test_gather diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 new file mode 100644 index 0000000..e681496 --- /dev/null +++ b/test/test_gatherv.f90 @@ -0,0 +1,127 @@ +program test_gatherv + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: send1(:), send2(:,:) + real(sp), allocatable :: recv1(:), recv2(:,:) + real(sp) :: send0 + integer, allocatable :: recvcounts(:) + integer, allocatable :: displs(:) + integer :: ii, nrecv + character(100) :: formstr + character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + + call mpifx_init() + call mycomm%init() + + ! R1 -> R1 + if (mycomm%lead) then + write(*, *) 'Test gather rank=1 -> rank=1' + end if + allocate(send1(mycomm%rank+1)) + send1 = real(mycomm%rank+1, sp) + if (mycomm%lead) then + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv1(nrecv)) + allocate(recvcounts(mycomm%size)) + do ii = 1, mycomm%size + recvcounts(ii) = ii + end do + else + allocate(recv1(0)) + end if + call mpifx_gatherv(mycomm, send1, recv1, recvcounts) + if (mycomm%lead) then + write(*, *) "Recv1 buffer:", recv1 + deallocate(recvcounts) + end if + deallocate(recv1) + + ! R2 -> R2 + if (mycomm%lead) then + write(*, *) + write(*, *) 'Test gather rank=2 -> rank=2' + end if + allocate(send2(10, mycomm%rank+1)) + send2 = real(mycomm%rank + 1, sp) + if (mycomm%lead) then + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv2(10, nrecv)) + recv2 = 0 + allocate(recvcounts(mycomm%size)) + do ii = 1, mycomm%size + recvcounts(ii) = 10*ii + end do + else + allocate(recv2(0,0)) + end if + call mpifx_gatherv(mycomm, send2, recv2, recvcounts) + if (mycomm%lead) then + write(*, *) "Recv2 buffer:", recv2(:,:) + deallocate(recvcounts) + end if + deallocate(recv2) + + ! R0 -> R1 with specified receive pattern + if (mycomm%lead) then + write(*, *) + write(*, *) 'Test gather scalar -> rank=1' + end if + send0 = real(mycomm%rank + 1, sp) + if (mycomm%lead) then + nrecv = mycomm%size + allocate(recv1(nrecv)) + allocate(recvcounts(mycomm%size)) + recvcounts = 1 + allocate(displs(mycomm%size)) + ! set a non trivial displs vector + do ii = 1, mycomm%size + displs(ii) = mycomm%size - ii + end do + else + allocate(recv1(0)) + end if + call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) + if (mycomm%lead) then + write(*, *) "Recv1 buffer:", recv1 + deallocate(recvcounts) + deallocate(displs) + end if + deallocate(recv1) + + ! R0 -> R1 with specified receive pattern including gaps + if (mycomm%lead) then + write(*, *) + write(*, *) 'Test gather scalar -> rank=1' + end if + send0 = real(mycomm%rank + 1, sp) + if (mycomm%lead) then + nrecv = mycomm%size + allocate(recv1(2*nrecv)) + allocate(recvcounts(mycomm%size)) + recvcounts = 1 + allocate(displs(mycomm%size)) + ! set a non trivial displs vector + do ii = 1, mycomm%size + displs(ii) = 2*ii-1 + end do + ! mark untouched elements + recv1 = -1 + else + allocate(recv1(0)) + end if + call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) + if (mycomm%lead) then + write(*, *) "Recv1 buffer:", recv1 + deallocate(recvcounts) + deallocate(displs) + end if + deallocate(recv1) + + call mpifx_finalize() + +end program test_gatherv diff --git a/test/test_reduce.f90 b/test/test_reduce.f90 new file mode 100644 index 0000000..b5f515b --- /dev/null +++ b/test/test_reduce.f90 @@ -0,0 +1,43 @@ +program test_reduce + use libmpifx_module + implicit none + + integer, parameter :: dp = kind(1.0d0) + + type(mpifx_comm) :: mycomm + integer :: vali0, resvali0 + real(dp) :: valr(3), resvalr(3) + + call mpifx_init() + call mycomm%init() + + ! Reduction of a scalarw + vali0 = mycomm%rank * 2 + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%rank, & + & "Value to be operated on:", vali0 + call mpifx_reduce(mycomm, vali0, resvali0, MPI_SUM) + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%rank, & + & "Obtained result (sum):", resvali0 + + ! Reduction of an array + valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + resvalr(:) = 0.0_dp + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & + & "Value to be operated on:", valr(:) + call mpifx_reduce(mycomm, valr, resvalr, MPI_PROD) + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & + & "Obtained result (prod):", resvalr(:) + + ! In place summation + resvalr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 5, mycomm%rank, & + & "Value to be operated on:", resvalr(:) + call mpifx_reduceip(mycomm, resvalr, MPI_SUM) + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 6, mycomm%rank, & + & "Obtained result (sum):", resvalr(:) + + call mpifx_finalize() + +end program test_reduce diff --git a/test/test_scatter.f90 b/test/test_scatter.f90 new file mode 100644 index 0000000..7bbbad3 --- /dev/null +++ b/test/test_scatter.f90 @@ -0,0 +1,66 @@ +program test_scatter + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:), send2(:,:) + integer :: recv0 + integer, allocatable :: recv1(:) + character(100) :: formstr + character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + integer :: ii + + call mpifx_init() + call mycomm%init() + + ! I1 -> I0 + if (mycomm%lead) then + allocate(send1(mycomm%size)) + send1(:) = [ (ii, ii = 1, size(send1)) ] + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 1, mycomm%rank, & + & "Send1 buffer:", send1 + else + allocate(send1(0)) + end if + recv0 = 0 + call mpifx_scatter(mycomm, send1, recv0) + write(formstr, "(A,I0,A)") "A,", 1, "(1X,I0))" + write(*, label // formstr) 2, mycomm%rank, & + & "Recv0 buffer:", recv0 + + ! I1 -> I1 + if (mycomm%lead) then + deallocate(send1) + allocate(send1(2 * mycomm%size)) + send1(:) = [ (ii, ii = 1, size(send1)) ] + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 3, mycomm%rank, & + & "Send1 buffer:", send1 + end if + allocate(recv1(2)) + recv1(:) = 0 + call mpifx_scatter(mycomm, send1, recv1) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 4, mycomm%rank, & + & "Recv1 buffer:", recv1 + + ! I2 -> I1 + if (mycomm%lead) then + allocate(send2(2, mycomm%size)) + send2(:,:) = reshape(send1, [ 2, mycomm%size ]) + write(formstr, "(A,I0,A)") "A,", size(send2), "(1X,I0))" + write(*, label // formstr) 5, mycomm%rank, & + & "Send2 buffer:", send2 + else + allocate(send2(0,0)) + end if + recv1(:) = 0 + call mpifx_scatter(mycomm, send2, recv1) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 6, mycomm%rank, & + & "Recv1 buffer:", recv1 + + call mpifx_finalize() + +end program test_scatter diff --git a/test/test_scatterv.f90 b/test/test_scatterv.f90 new file mode 100644 index 0000000..6de8d51 --- /dev/null +++ b/test/test_scatterv.f90 @@ -0,0 +1,85 @@ +program test_scatterv + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:), send2(:,:) + integer :: recv0 + integer, allocatable :: recv1(:), sendcount(:), displs(:) + character(100) :: formstr + character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" + integer :: ii + + call mpifx_init() + call mycomm%init() + + ! I1 -> I0 + if (mycomm%lead) then + allocate(send1(mycomm%size)) + allocate(sendcount(mycomm%size)) + send1(:) = [ (ii, ii = 1, size(send1)) ] + sendcount(:) = 1 + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 1, mycomm%rank, "Send1 buffer:", send1 + else + allocate(send1(0)) + allocate(sendcount(0)) + end if + recv0 = 0 + call mpifx_scatterv(mycomm, send1, sendcount, recv0) + write(formstr, "(A,I0,A)") "A,", 1, "(1X,I0))" + write(*, label // formstr) 2, mycomm%rank, "Recv0 buffer:", recv0 + + ! I1 -> I1 + if (mycomm%lead) then + deallocate(send1) + allocate(send1(2 * mycomm%size)) + sendcount(:) = 2 + send1(:) = [ (ii, ii = 1, size(send1)) ] + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 3, mycomm%rank, "Send1 buffer:", send1 + end if + allocate(recv1(2)) + recv1(:) = 0 + call mpifx_scatterv(mycomm, send1, sendcount, recv1) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 4, mycomm%rank, "Recv1 buffer:", recv1 + + ! I2 -> I1 + if (mycomm%lead) then + allocate(send2(2, mycomm%size)) + sendcount(:) = 2 + send2(:,:) = reshape(send1, [ 2, mycomm%size ]) + write(formstr, "(A,I0,A)") "A,", size(send2), "(1X,I0))" + write(*, label // formstr) 5, mycomm%rank, & + & "Send2 buffer:", send2 + else + allocate(send2(0,0)) + end if + recv1(:) = 0 + call mpifx_scatterv(mycomm, send2, sendcount, recv1) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 6, mycomm%rank, & + & "Recv1 buffer:", recv1 + + ! I1 -> I1 + if (mycomm%lead) then + deallocate(send1) + allocate(send1(2 * mycomm%size)) + send1(:) = [ (ii, ii = 1, size(send1)) ] + sendcount(:) = 1 + allocate(displs(mycomm%size)) + displs(:) = [ (ii, ii = 1, size(send1), 2) ] + write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" + write(*, label // formstr) 7, mycomm%rank, "Send1 buffer:", send1 + end if + deallocate(recv1) + allocate(recv1(1)) + recv1(:) = 0 + call mpifx_scatterv(mycomm, send1, sendcount, recv1, displs=displs) + write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" + write(*, label // formstr) 8, mycomm%rank, "Recv1 buffer:", recv1 + + call mpifx_finalize() + +end program test_scatterv diff --git a/test/test_send_recv.f90 b/test/test_send_recv.f90 index a4e58b2..ae228a1 100644 --- a/test/test_send_recv.f90 +++ b/test/test_send_recv.f90 @@ -3,18 +3,18 @@ program test_send_recv implicit none character(100) :: msg - type(mpifx_comm) :: mympi + type(mpifx_comm) :: mycomm integer :: source call mpifx_init() - call mympi%init() - if (.not. mympi%master) then - write(msg, "(A,I0,A)") "Hello from process ", mympi%iproc, "!" - call mpifx_send(mympi, msg, mympi%imaster) + call mycomm%init() + if (.not. mycomm%lead) then + write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + call mpifx_send(mycomm, msg, mycomm%leadrank) else - write(*, "(A)") "Master node:" - do source = 1, mympi%nproc - 1 - call mpifx_recv(mympi, msg, source) + write(*, "(A)") "Lead node:" + do source = 1, mycomm%size - 1 + call mpifx_recv(mycomm, msg, source) write(*,"(A,A)") "Message received: ", trim(msg) end do end if diff --git a/utils/export/mpifx-config.cmake.in b/utils/export/mpifx-config.cmake.in new file mode 100644 index 0000000..49f67b6 --- /dev/null +++ b/utils/export/mpifx-config.cmake.in @@ -0,0 +1,10 @@ +@PACKAGE_INIT@ + +include(CMakeFindDependencyMacro) + +if(NOT TARGET MpiFx::MpiFx) + if(NOT TARGET MPI::MPI_Fortran) + find_dependency(MPI) + endif() + include(${CMAKE_CURRENT_LIST_DIR}/mpifx-targets.cmake) +endif() diff --git a/utils/export/mpifx.pc.in b/utils/export/mpifx.pc.in new file mode 100644 index 0000000..dfd8105 --- /dev/null +++ b/utils/export/mpifx.pc.in @@ -0,0 +1,9 @@ +Name: mpifx +Description: Modern Fortran wrappers for MPI +Version: @PROJECT_VERSION@ +URL: https://github.com/dftbplus/mpifx + +Requires: @PKGCONFIG_REQUIRES@ +Libs: @PKGCONFIG_LIBS@ +Libs.private: @PKGCONFIG_LIBS_PRIVATE@ +Cflags: @PKGCONFIG_C_FLAGS@