From 815cbd0e42c0652c4e698c0e25d7a14bbd77abaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 21 Aug 2013 23:04:14 +0200 Subject: [PATCH 01/72] Wrapper for MPI_REDUCE implemented, library restructured. --- .gitignore | 2 +- src/Makefile.lib | 28 +++-- src/libmpifx.F90 | 12 +- src/mpi_constants.F90 | 15 +++ src/mpi_constants.m4 | 1 + src/mpifx_abort.F90 | 31 ++++- src/mpifx_barrier.F90 | 31 ++++- src/mpifx_bcast.F90 | 48 ++++---- src/mpifx_bcast.m4 | 14 +-- src/mpifx_comm.F90 | 70 ++++++++++- src/mpifx_common.F90 | 38 +----- src/mpifx_finalize.F90 | 25 +++- src/mpifx_helper.F90 | 56 +++++++++ src/mpifx_helper.m4 | 1 + src/mpifx_init.F90 | 25 +++- src/mpifx_recv.F90 | 145 ++++++++++++++++++++++ src/mpifx_recv.m4 | 39 ++++++ src/mpifx_reduce.F90 | 131 ++++++++++++++++++++ src/mpifx_reduce.m4 | 37 ++++++ src/mpifx_send.F90 | 146 ++++++++++++++++++++++ src/mpifx_send.m4 | 34 ++++++ src/mpifx_send_recv.F90 | 253 --------------------------------------- src/mpifx_send_recv.m4 | 72 ----------- test/GNUmakefile | 25 ++-- test/test_bcast.f90 | 60 +++++----- test/test_comm_split.f90 | 17 +++ test/test_reduce.f90 | 29 +++++ test/test_send_recv.f90 | 14 +-- 28 files changed, 920 insertions(+), 479 deletions(-) create mode 100644 src/mpi_constants.F90 create mode 100644 src/mpi_constants.m4 create mode 100644 src/mpifx_helper.F90 create mode 100644 src/mpifx_helper.m4 create mode 100644 src/mpifx_recv.F90 create mode 100644 src/mpifx_recv.m4 create mode 100644 src/mpifx_reduce.F90 create mode 100644 src/mpifx_reduce.m4 create mode 100644 src/mpifx_send.F90 create mode 100644 src/mpifx_send.m4 delete mode 100644 src/mpifx_send_recv.F90 delete mode 100644 src/mpifx_send_recv.m4 create mode 100644 test/test_comm_split.f90 create mode 100644 test/test_reduce.f90 diff --git a/.gitignore b/.gitignore index 44d41ad..91cd443 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,4 @@ *.a *.mod make.arch - +doc/doxygen/_build diff --git a/src/Makefile.lib b/src/Makefile.lib index 870580f..084ce8e 100644 --- a/src/Makefile.lib +++ b/src/Makefile.lib @@ -17,8 +17,9 @@ .SUFFIXES: .SUFFIXES: .f90 .F90 .o -FILENAMES = libmpifx mpifx_comm mpifx_common mpifx_barrier mpifx_bcast \ - mpifx_send_recv mpifx_abort mpifx_init mpifx_finalize +FILENAMES = libmpifx mpifx_helper mpifx_comm mpifx_common mpifx_barrier \ + mpifx_bcast mpifx_send mpifx_recv mpifx_abort mpifx_init mpifx_finalize \ + mpifx_reduce mpi_constants TARGETLIB = libmpifx.a $(TARGETLIB): $(patsubst %,%.o,$(FILENAMES)) @@ -42,16 +43,21 @@ realclean: clean # 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 +libmpifx.o: mpi_constants.o mpifx_comm.o mpifx_abort.o mpifx_barrier.o \ + mpifx_bcast.o mpifx_finalize.o mpifx_init.o mpifx_send.o mpifx_recv.o \ + mpifx_reduce.o +mpifx_abort.o: mpifx_common.o +mpifx_barrier.o: mpifx_common.o +mpifx_bcast.o: mpifx_common.o +mpifx_comm.o: mpifx_helper.o +mpifx_common.o: mpifx_helper.o mpifx_comm.o +mpi_constants.o: mpifx_finalize.o: mpifx_common.o +mpifx_helper.o: +mpifx_init.o: mpifx_common.o +mpifx_reduce.o: mpifx_common.o mpifx_common.o +mpifx_send.o: mpifx_common.o +mpifx_recv.o: mpifx_common.o ### Local Variables: diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 index 78f984a..9e3b431 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -1,15 +1,17 @@ !> \mainpage Fortran 2003 wrappers around MPI routines !! module libmpifx_module + use mpi_constants_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_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 implicit none - public end module libmpifx_module diff --git a/src/mpi_constants.F90 b/src/mpi_constants.F90 new file mode 100644 index 0000000..69b8d03 --- /dev/null +++ b/src/mpi_constants.F90 @@ -0,0 +1,15 @@ +include(mpi_constants.m4) + +!> Exports some MPI constants. +!! \cond HIDDEN +module mpi_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 + +end module mpi_constants_module + +!> \endcond diff --git a/src/mpi_constants.m4 b/src/mpi_constants.m4 new file mode 100644 index 0000000..8878874 --- /dev/null +++ b/src/mpi_constants.m4 @@ -0,0 +1 @@ +include(common.m4) diff --git a/src/mpifx_abort.F90 b/src/mpifx_abort.F90 index 8b8a4e1..2c4fd84 100644 --- a/src/mpifx_abort.F90 +++ b/src/mpifx_abort.F90 @@ -1,8 +1,8 @@ include(mpifx_abort.m4) - + +!> Contains wrapper for \c MPI_ABORT. module mpifx_abort_module use mpifx_common_module - use mpifx_comm_module implicit none private @@ -11,19 +11,38 @@ module mpifx_abort_module contains !> Aborts MPI processes for the given communicator. - !! \param mympi MPI handler. + !! + !! \param mycomm 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 + !! \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 _handle_inoptflag(errorcode0, errorcode, -1) - call mpi_abort(mympi%id, errorcode0, error0) + call mpi_abort(mycomm%id, errorcode0, error0) call handle_errorflag(error0, "MPI_ABORT in mpifx_abort", error) end subroutine mpifx_abort diff --git a/src/mpifx_barrier.F90 b/src/mpifx_barrier.F90 index 65e1452..c444013 100644 --- a/src/mpifx_barrier.F90 +++ b/src/mpifx_barrier.F90 @@ -1,8 +1,8 @@ include(mpifx_barrier.m4) - + +!> Contains wrapper for \c MPI_BARRIER. module mpifx_barrier_module use mpifx_common_module - use mpifx_comm_module implicit none private @@ -11,15 +11,34 @@ module mpifx_barrier_module contains !> Sets a barrier. - !! \param mympi MPI handler. + !! + !! \param mycomm MPI communicator. !! \param error Optional error flag. - subroutine mpifx_barrier(mympi, error) - type(mpifx_comm), intent(in) :: mympi + !! + !! 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(mympi%id, error0) + call mpi_barrier(mycomm%id, error0) call handle_errorflag(error0, "MPI_BARRIER in mpifx_barrier", error) end subroutine mpifx_barrier diff --git a/src/mpifx_bcast.F90 b/src/mpifx_bcast.F90 index ed79866..9e2c889 100644 --- a/src/mpifx_bcast.F90 +++ b/src/mpifx_bcast.F90 @@ -1,28 +1,8 @@ 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 -!! +!> Contains wrapper for \c MPI_BCAST. module mpifx_bcast_module use mpifx_common_module - use mpifx_comm_module implicit none private @@ -32,11 +12,29 @@ module mpifx_bcast_module !! !! \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. + !! type integer (i), real (s), double precision (d), complex (c), + !! double complex (z), logical (l) and character (h). Its rank can vary from + !! zero (scalar) up to the maximum rank. !! - !! \see MPI documentation (routine mpi_bcast) + !! \see MPI documentation (\c MPI_BCAST) + !! + !! Example: + !! + !! program test_bcast + !! use libmpifx_module + !! + !! type(mpifx) :: mycomm + !! integer :: buffer(3) + !! + !! call mycomm%init() + !! if (mycomm%master) then + !! buffer(:) = [ 1, 2, 3 ] + !! end if + !! call mpifx_bcast(mycomm, buffer) + !! print "(A,I2.2,A,3I5)", "BUFFER:", mycomm%iproc, ":", buffer + !! call mycomm%destruct() + !! + !! end program test_bcast !! interface mpifx_bcast module procedure mpifx_bcast_i0, mpifx_bcast_i1, mpifx_bcast_i2, & diff --git a/src/mpifx_bcast.m4 b/src/mpifx_bcast.m4 index c3be7d8..c1231d9 100644 --- a/src/mpifx_bcast.m4 +++ b/src/mpifx_bcast.m4 @@ -1,7 +1,7 @@ include(common.m4) dnl ************************************************************************ -dnl *** bcast +dnl *** mpifx_bcast dnl ************************************************************************ define(`_subroutine_mpifx_bcast',`dnl @@ -11,22 +11,22 @@ 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 mycomm 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 root Root node for the broadcast (default: mycomm%imaster). !! \param error Optional error handling flag. !! -subroutine mpifx_bcast_$1(mympi, msg, root, error) - type(mpifx_comm), intent(in) :: mympi +subroutine mpifx_bcast_$1(mycomm, msg, root, error) + type(mpifx_comm), intent(in) :: mycomm $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) + _handle_inoptflag(root0, root, mycomm%imaster) + call mpi_bcast(msg, $4, $5, root0, mycomm%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 index b1734a9..4b02ad3 100644 --- a/src/mpifx_comm.F90 +++ b/src/mpifx_comm.F90 @@ -1,7 +1,9 @@ include(mpifx_comm.m4) - + +!> Contains the extended MPI communicator. module mpifx_comm_module - use mpifx_common_module + use mpifx_helper_module + use mpi implicit none private @@ -18,23 +20,28 @@ module mpifx_comm_module !> 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 MPI Communicator. + !! \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, error) + 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 - self%id = default_communicator + _handle_inoptflag(self%id, commid, MPI_COMM_WORLD) 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 @@ -49,5 +56,58 @@ subroutine mpifx_comm_init(self, error) self%master = (self%iproc == self%imaster) 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%nproc / 2 + !! mygroup = allproc%iproc / groupsize + !! call allproc%split(mygroup, allproc%iproc, groupproc) + !! write(*, "(3(A,1X,I0,1X))") "ID:", allproc%iproc, "SUBGROUP", & + !! & mygroup, "SUBGROUP ID", groupproc%iproc + !! 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/src/mpifx_common.F90 b/src/mpifx_common.F90 index 9e160f5..8dd2333 100644 --- a/src/mpifx_common.F90 +++ b/src/mpifx_common.F90 @@ -1,43 +1,13 @@ include(mpifx_common.m4) -!> Common helper routines. +!> Exports constants, helper functions, MPI descriptor and legace MPI routines. !! \cond HIDDEN module mpifx_common_module - use mpi ! Must be provided by the MPI framework + use mpi + use mpifx_helper_module + use mpifx_comm_module 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_finalize.F90 b/src/mpifx_finalize.F90 index 7e46e8c..5415b58 100644 --- a/src/mpifx_finalize.F90 +++ b/src/mpifx_finalize.F90 @@ -1,5 +1,6 @@ include(mpifx_finalize.m4) - + +!> Contains wrapper for \c MPI_FINALIZE. module mpifx_finalize_module use mpifx_common_module implicit none @@ -9,6 +10,28 @@ module mpifx_finalize_module 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 diff --git a/src/mpifx_helper.F90 b/src/mpifx_helper.F90 new file mode 100644 index 0000000..36647ea --- /dev/null +++ b/src/mpifx_helper.F90 @@ -0,0 +1,56 @@ +include(mpifx_helper.m4) + +!> Exports constants and helper routine(s). +!! \cond HIDDEN +module mpifx_helper_module + use mpi + implicit none + private + + public :: default_tag, sp, dp + public :: handle_errorflag + + !> 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) + +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 + + integer :: aborterror + + if (present(error)) then + error = error0 + elseif (error0 /= 0) then + write(*, "(A)") "Operation failed!" + write(*, "(A)") msg + write(*, "(A,I0)") "Error: ", error0 + 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 + + end subroutine handle_errorflag + + +end module mpifx_helper_module + +!> \endcond diff --git a/src/mpifx_helper.m4 b/src/mpifx_helper.m4 new file mode 100644 index 0000000..8878874 --- /dev/null +++ b/src/mpifx_helper.m4 @@ -0,0 +1 @@ +include(common.m4) diff --git a/src/mpifx_init.F90 b/src/mpifx_init.F90 index 068dd89..344304a 100644 --- a/src/mpifx_init.F90 +++ b/src/mpifx_init.F90 @@ -1,5 +1,6 @@ include(mpifx_init.m4) - + +!> Contains wrapper for \c MPI_INIT. module mpifx_init_module use mpifx_common_module implicit none @@ -9,6 +10,28 @@ module mpifx_init_module 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 diff --git a/src/mpifx_recv.F90 b/src/mpifx_recv.F90 new file mode 100644 index 0000000..4640665 --- /dev/null +++ b/src/mpifx_recv.F90 @@ -0,0 +1,145 @@ +include(mpifx_recv.m4) + +!> 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%master) then + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%iproc, "!" + !! call mpifx_send(mycomm, msg, mycomm%imaster) + !! else + !! write(*, "(A)") "Master node:" + !! do source = 1, mycomm%nproc - 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 + 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_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_recv_module diff --git a/src/mpifx_recv.m4 b/src/mpifx_recv.m4 new file mode 100644 index 0000000..a555b78 --- /dev/null +++ b/src/mpifx_recv.m4 @@ -0,0 +1,39 @@ +include(common.m4) + +dnl ************************************************************************ +dnl *** mpifx_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 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_$1(mycomm, msg, source, tag, status, error) + type(mpifx_comm), intent(in) :: mycomm + $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, mycomm%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/src/mpifx_reduce.F90 b/src/mpifx_reduce.F90 new file mode 100644 index 0000000..805366d --- /dev/null +++ b/src/mpifx_reduce.F90 @@ -0,0 +1,131 @@ +include(mpifx_reduce.m4) + +!> Contains wrapper for \c MPI_REDUCE. +module mpifx_reduce_module + use mpifx_common_module + implicit none + private + + public :: mpifx_reduce + + !> 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) 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_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%iproc + 1) * 1.2_dp, & + !! & (mycomm%iproc + 1) * 4.3_dp, (mycomm%iproc + 1) * 3.8_dp ] + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%iproc, & + !! & "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%iproc, & + !! & "Obtained result (prod):", resvalr(:) + !! call mpifx_finalize() + !! + !! end program test_reduce + !! + interface mpifx_reduce + module procedure mpifx_reduce_i0, mpifx_reduce_i1, mpifx_reduce_i2, & + & mpifx_reduce_i3, mpifx_reduce_i4, mpifx_reduce_i5, mpifx_reduce_i6 + module procedure mpifx_reduce_s0, mpifx_reduce_s1, mpifx_reduce_s2, & + & mpifx_reduce_s3, mpifx_reduce_s4, mpifx_reduce_s5, mpifx_reduce_s6 + module procedure mpifx_reduce_d0, mpifx_reduce_d1, mpifx_reduce_d2, & + & mpifx_reduce_d3, mpifx_reduce_d4, mpifx_reduce_d5, mpifx_reduce_d6 + module procedure mpifx_reduce_c0, mpifx_reduce_c1, mpifx_reduce_c2, & + & mpifx_reduce_c3, mpifx_reduce_c4, mpifx_reduce_c5, mpifx_reduce_c6 + module procedure mpifx_reduce_z0, mpifx_reduce_z1, mpifx_reduce_z2, & + & mpifx_reduce_z3, mpifx_reduce_z4, mpifx_reduce_z5, mpifx_reduce_z6 + module procedure mpifx_reduce_l0, mpifx_reduce_l1, mpifx_reduce_l2, & + & mpifx_reduce_l3, mpifx_reduce_l4, mpifx_reduce_l5, mpifx_reduce_l6 + end interface + +contains + + _subroutine_mpifx_reduce(i0, integer, , 1, MPI_INTEGER) + _subroutine_mpifx_reduce(i1, integer, (:), size(operand), MPI_INTEGER) + _subroutine_mpifx_reduce(i2, integer, (:,:), size(operand), MPI_INTEGER) + _subroutine_mpifx_reduce(i3, integer, (:,:,:), size(operand), MPI_INTEGER) + _subroutine_mpifx_reduce(i4, integer, (:,:,:,:), size(operand), MPI_INTEGER) + _subroutine_mpifx_reduce(i5, integer, (:,:,:,:,:), size(operand), MPI_INTEGER) + _subroutine_mpifx_reduce(i6, integer, (:,:,:,:,:,:), size(operand), + MPI_INTEGER) + + _subroutine_mpifx_reduce(s0, real(sp), , 1, MPI_REAL) + _subroutine_mpifx_reduce(s1, real(sp), (:), size(operand), MPI_REAL) + _subroutine_mpifx_reduce(s2, real(sp), (:,:), size(operand), MPI_REAL) + _subroutine_mpifx_reduce(s3, real(sp), (:,:,:), size(operand), MPI_REAL) + _subroutine_mpifx_reduce(s4, real(sp), (:,:,:,:), size(operand), MPI_REAL) + _subroutine_mpifx_reduce(s5, real(sp), (:,:,:,:,:), size(operand), MPI_REAL) + _subroutine_mpifx_reduce(s6, real(sp), (:,:,:,:,:,:), size(operand), + MPI_REAL) + + _subroutine_mpifx_reduce(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduce(d1, real(dp), (:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduce(d2, real(dp), (:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduce(d3, real(dp), (:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduce(d4, real(dp), (:,:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduce(d5, real(dp), (:,:,:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduce(d6, real(dp), (:,:,:,:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_reduce(c0, complex(sp), , 1, MPI_COMPLEX) + _subroutine_mpifx_reduce(c1, complex(sp), (:), size(operand), MPI_COMPLEX) + _subroutine_mpifx_reduce(c2, complex(sp), (:,:), size(operand), MPI_COMPLEX) + _subroutine_mpifx_reduce(c3, complex(sp), (:,:,:), size(operand), MPI_COMPLEX) + _subroutine_mpifx_reduce(c4, complex(sp), (:,:,:,:), size(operand), + MPI_COMPLEX) + _subroutine_mpifx_reduce(c5, complex(sp), (:,:,:,:,:), size(operand), + MPI_COMPLEX) + _subroutine_mpifx_reduce(c6, complex(sp), (:,:,:,:,:,:), size(operand), + MPI_COMPLEX) + + _subroutine_mpifx_reduce(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduce(z1, complex(dp), (:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduce(z2, complex(dp), (:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduce(z3, complex(dp), (:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduce(z4, complex(dp), (:,:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduce(z5, complex(dp), (:,:,:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduce(z6, complex(dp), (:,:,:,:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_reduce(l0, logical, , 1, MPI_LOGICAL) + _subroutine_mpifx_reduce(l1, logical, (:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_reduce(l2, logical, (:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_reduce(l3, logical, (:,:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_reduce(l4, logical, (:,:,:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_reduce(l5, logical, (:,:,:,:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_reduce(l6, logical, (:,:,:,:,:,:), size(operand), + MPI_LOGICAL) + + +end module mpifx_reduce_module diff --git a/src/mpifx_reduce.m4 b/src/mpifx_reduce.m4 new file mode 100644 index 0000000..72e8ba8 --- /dev/null +++ b/src/mpifx_reduce.m4 @@ -0,0 +1,37 @@ +include(common.m4) + +dnl ************************************************************************ +dnl *** mpifx_reduce +dnl ************************************************************************ + +define(`_subroutine_mpifx_reduce',`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 +!> Reduces results on one process (type $1). +!! +!! \param mycomm MPI communicator. +!! \param operand Quantity to be reduced. +!! \param result Contains result on exit. +!! \param operator Reduction operator +!! \param root Root process for the result (default: mycomm%imaster) +!! \param error Error code on exit. +!! +subroutine mpifx_reduce_$1(mycomm, operand, result, operator, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: operand$3 + $2, intent(inout) :: result$3 + integer, intent(in) :: operator + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + _handle_inoptflag(root0, root, mycomm%imaster) + call mpi_reduce(operand, result, $4, $5, operator, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_$1", error) + +end subroutine mpifx_reduce_$1 +') diff --git a/src/mpifx_send.F90 b/src/mpifx_send.F90 new file mode 100644 index 0000000..3b1efe3 --- /dev/null +++ b/src/mpifx_send.F90 @@ -0,0 +1,146 @@ +include(mpifx_send.m4) + +!> 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%master) then + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%iproc, "!" + !! call mpifx_send(mycomm, msg, mycomm%imaster) + !! else + !! write(*, "(A)") "Master node:" + !! do source = 1, mycomm%nproc - 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 + 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 + + +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) + + +end module mpifx_send_module diff --git a/src/mpifx_send.m4 b/src/mpifx_send.m4 new file mode 100644 index 0000000..758b142 --- /dev/null +++ b/src/mpifx_send.m4 @@ -0,0 +1,34 @@ +include(common.m4) + +dnl ************************************************************************ +dnl *** mpifx_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 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_$1(mycomm, msg, dest, tag, error) + type(mpifx_comm), intent(in) :: mycomm + $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, mycomm%id, error0) + call handle_errorflag(error0, "MPI_SEND in mpifx_send_$1", error) + +end subroutine mpifx_send_$1 +') 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/GNUmakefile b/test/GNUmakefile index a989786..a857406 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -8,7 +8,7 @@ ############################################################################ # Directory where library source can be found -SRCDIR_MPIFX = ../src +SRCDIR = ../src include ../make.arch @@ -23,36 +23,31 @@ include ../make.arch .SUFFIXES: .SUFFIXES: .f90 .F90 .o .m4 -BINARIES = test_bcast test_send_recv +BINARIES = test_bcast test_send_recv test_comm_split test_reduce all: $(BINARIES) - -test_bcast: test_bcast.o - $(LN) $(LNOPT) -o $@ $^ -L./ -lmpifx - -test_send_recv: test_send_recv.o +# General rule for executables (without suffix) +%: %.o $(LN) $(LNOPT) -o $@ $^ -L./ -lmpifx - %.o: %.f90 $(FXX) $(FXXOPT) -c $< .PHONY: clean realclean clean: - $(MAKE) -f $(SRCDIR_MPIFX)/Makefile.lib clean + $(MAKE) -f $(SRCDIR)/Makefile.lib clean rm -f *.mod *.o realclean: clean - $(MAKE) -f $(SRCDIR_MPIFX)/Makefile.lib realclean + $(MAKE) -f $(SRCDIR)/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 +$(BINARIES): libmpifx.a ############################################################################ @@ -62,6 +57,6 @@ 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" + M4="$(M4)" M4OPT="-I $(SRCDIR) $(M4OPT)" \ + VPATH="$(SRCDIR)" \ + -f "$(SRCDIR)/Makefile.lib" diff --git a/test/test_bcast.f90 b/test/test_bcast.f90 index 4888b3b..443bf45 100644 --- a/test/test_bcast.f90 +++ b/test/test_bcast.f90 @@ -4,7 +4,7 @@ program test_bcast 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 +13,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%iproc, ":", buffer + if (mycomm%master) 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%iproc, ":", buffer + call mpifx_bcast(mycomm, buffer) + print "(A,I2.2,A,3I5)", "CHK03:", mycomm%iproc, ":", 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%iproc, ":", lbuffer + if (mycomm%master) 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%iproc, ":", lbuffer + call mpifx_bcast(mycomm, lbuffer) + print "(A,I2.2,A,3L5)", "CHK06:", mycomm%iproc, ":", 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%iproc, ":", rbuffer + if (mycomm%master) 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%iproc, ":", rbuffer + call mpifx_bcast(mycomm, rbuffer) + print "(A,I2.2,A,4F10.6)", "CHK09:", mycomm%iproc, ":", 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%iproc, ":", cbuffer + if (mycomm%master) 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%iproc, ":", cbuffer + call mpifx_bcast(mycomm, cbuffer) + print "(A,I2.2,A,2F10.6)", "CHK12:", mycomm%iproc, ":", 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%iproc, ":", text + if (mycomm%master) 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%iproc, ":", text + call mpifx_bcast(mycomm, text) + print "(A,I2.2,A,A6)", "CHK15:", mycomm%iproc, ":", text call mpifx_finalize() diff --git a/test/test_comm_split.f90 b/test/test_comm_split.f90 new file mode 100644 index 0000000..33c22ae --- /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%nproc / 2 + mygroup = allproc%iproc / groupsize + call allproc%split(mygroup, allproc%iproc, groupproc) + write(*, "(3(A,1X,I0,1X))") "GLOBAL ID:", allproc%iproc, "SUBGROUP", & + & mygroup, "SUBGROUP ID", groupproc%iproc + call mpifx_finalize() + +end program test_comm_split diff --git a/test/test_reduce.f90 b/test/test_reduce.f90 new file mode 100644 index 0000000..7662463 --- /dev/null +++ b/test/test_reduce.f90 @@ -0,0 +1,29 @@ +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() + + vali0 = mycomm%iproc * 2 + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%iproc, & + & "Value to be operated on:", vali0 + call mpifx_reduce(mycomm, vali0, resvali0, MPI_SUM) + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%iproc, & + & "Obtained result (sum):", resvali0 + valr(:) = [ real(mycomm%iproc + 1, dp) * 1.2, & + & real(mycomm%iproc + 1, dp) * 4.3, real(mycomm%iproc + 1, dp) * 3.8 ] + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%iproc, & + & "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%iproc, & + & "Obtained result (prod):", resvalr(:) + call mpifx_finalize() + +end program test_reduce diff --git a/test/test_send_recv.f90 b/test/test_send_recv.f90 index a4e58b2..045c886 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%master) then + write(msg, "(A,I0,A)") "Hello from process ", mycomm%iproc, "!" + call mpifx_send(mycomm, msg, mycomm%imaster) else write(*, "(A)") "Master node:" - do source = 1, mympi%nproc - 1 - call mpifx_recv(mympi, msg, source) + do source = 1, mycomm%nproc - 1 + call mpifx_recv(mycomm, msg, source) write(*,"(A,A)") "Message received: ", trim(msg) end do end if From afe962293bf30678c5a5e38bd24f961473288fba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Thu, 22 Aug 2013 15:10:35 +0200 Subject: [PATCH 02/72] Renaming mpifx_comm components for more MPI-like naming. --- src/mpifx_bcast.F90 | 2 +- src/mpifx_bcast.m4 | 4 ++-- src/mpifx_comm.F90 | 24 ++++++++++++------------ src/mpifx_recv.F90 | 6 +++--- src/mpifx_reduce.F90 | 8 ++++---- src/mpifx_reduce.m4 | 4 ++-- src/mpifx_send.F90 | 6 +++--- test/test_bcast.f90 | 30 +++++++++++++++--------------- test/test_comm_split.f90 | 10 +++++----- test/test_reduce.f90 | 14 +++++++------- test/test_send_recv.f90 | 6 +++--- 11 files changed, 57 insertions(+), 57 deletions(-) diff --git a/src/mpifx_bcast.F90 b/src/mpifx_bcast.F90 index 9e2c889..39f1ee6 100644 --- a/src/mpifx_bcast.F90 +++ b/src/mpifx_bcast.F90 @@ -31,7 +31,7 @@ module mpifx_bcast_module !! buffer(:) = [ 1, 2, 3 ] !! end if !! call mpifx_bcast(mycomm, buffer) - !! print "(A,I2.2,A,3I5)", "BUFFER:", mycomm%iproc, ":", buffer + !! print "(A,I2.2,A,3I5)", "BUFFER:", mycomm%rank, ":", buffer !! call mycomm%destruct() !! !! end program test_bcast diff --git a/src/mpifx_bcast.m4 b/src/mpifx_bcast.m4 index c1231d9..05f3cab 100644 --- a/src/mpifx_bcast.m4 +++ b/src/mpifx_bcast.m4 @@ -14,7 +14,7 @@ dnl $5: corresponding MPI type !! \param mycomm MPI descriptor !! \param msg Msg to be broadcasted on root and received on non-root !! nodes. -!! \param root Root node for the broadcast (default: mycomm%imaster). +!! \param root Root node for the broadcast (default: mycomm%masterrank). !! \param error Optional error handling flag. !! subroutine mpifx_bcast_$1(mycomm, msg, root, error) @@ -25,7 +25,7 @@ subroutine mpifx_bcast_$1(mycomm, msg, root, error) integer :: root0, error0 - _handle_inoptflag(root0, root, mycomm%imaster) + _handle_inoptflag(root0, root, mycomm%masterrank) call mpi_bcast(msg, $4, $5, root0, mycomm%id, error0) call handle_errorflag(error0, "MPI_BCAST in mpifx_bcast_$1", error) diff --git a/src/mpifx_comm.F90 b/src/mpifx_comm.F90 index 4b02ad3..bc3d701 100644 --- a/src/mpifx_comm.F90 +++ b/src/mpifx_comm.F90 @@ -12,9 +12,9 @@ module mpifx_comm_module !> 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. + integer :: size !< Nr. of processes (size). + integer :: rank !< Rank of the current process. + integer :: masterrank !< Index of the master node. logical :: master !< True if current process is the master (rank == 0). contains !> Initializes the MPI environment. @@ -42,18 +42,18 @@ subroutine mpifx_comm_init(self, commid, error) integer :: error0 _handle_inoptflag(self%id, commid, MPI_COMM_WORLD) - call mpi_comm_size(self%id, self%nproc, error0) + 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%iproc, error0) + 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%imaster = 0 - self%master = (self%iproc == self%imaster) + self%masterrank = 0 + self%master = (self%rank == self%masterrank) end subroutine mpifx_comm_init @@ -80,11 +80,11 @@ end subroutine mpifx_comm_init !! !! call mpifx_init() !! call allproc%init() - !! groupsize = allproc%nproc / 2 - !! mygroup = allproc%iproc / groupsize - !! call allproc%split(mygroup, allproc%iproc, groupproc) - !! write(*, "(3(A,1X,I0,1X))") "ID:", allproc%iproc, "SUBGROUP", & - !! & mygroup, "SUBGROUP ID", groupproc%iproc + !! 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 diff --git a/src/mpifx_recv.F90 b/src/mpifx_recv.F90 index 4640665..aa4d079 100644 --- a/src/mpifx_recv.F90 +++ b/src/mpifx_recv.F90 @@ -32,11 +32,11 @@ module mpifx_recv_module !! call mpifx_init() !! call mycomm%init() !! if (.not. mycomm%master) then - !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%iproc, "!" - !! call mpifx_send(mycomm, msg, mycomm%imaster) + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + !! call mpifx_send(mycomm, msg, mycomm%masterrank) !! else !! write(*, "(A)") "Master node:" - !! do source = 1, mycomm%nproc - 1 + !! do source = 1, mycomm%size - 1 !! call mpifx_recv(mycomm, msg, source) !! write(*,"(A,A)") "Message received: ", trim(msg) !! end do diff --git a/src/mpifx_reduce.F90 b/src/mpifx_reduce.F90 index 805366d..2667038 100644 --- a/src/mpifx_reduce.F90 +++ b/src/mpifx_reduce.F90 @@ -33,12 +33,12 @@ module mpifx_reduce_module !! !! call mpifx_init() !! call mycomm%init() - !! valr(:) = [ (mycomm%iproc + 1) * 1.2_dp, & - !! & (mycomm%iproc + 1) * 4.3_dp, (mycomm%iproc + 1) * 3.8_dp ] - !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%iproc, & + !! 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%iproc, & + !! write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & !! & "Obtained result (prod):", resvalr(:) !! call mpifx_finalize() !! diff --git a/src/mpifx_reduce.m4 b/src/mpifx_reduce.m4 index 72e8ba8..fdeab48 100644 --- a/src/mpifx_reduce.m4 +++ b/src/mpifx_reduce.m4 @@ -16,7 +16,7 @@ dnl $5: corresponding MPI type !! \param operand Quantity to be reduced. !! \param result Contains result on exit. !! \param operator Reduction operator -!! \param root Root process for the result (default: mycomm%imaster) +!! \param root Root process for the result (default: mycomm%masterrank) !! \param error Error code on exit. !! subroutine mpifx_reduce_$1(mycomm, operand, result, operator, root, error) @@ -29,7 +29,7 @@ subroutine mpifx_reduce_$1(mycomm, operand, result, operator, root, error) integer :: root0, error0 - _handle_inoptflag(root0, root, mycomm%imaster) + _handle_inoptflag(root0, root, mycomm%masterrank) call mpi_reduce(operand, result, $4, $5, operator, root0, mycomm%id, error0) call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_$1", error) diff --git a/src/mpifx_send.F90 b/src/mpifx_send.F90 index 3b1efe3..0b67c36 100644 --- a/src/mpifx_send.F90 +++ b/src/mpifx_send.F90 @@ -32,11 +32,11 @@ module mpifx_send_module !! call mpifx_init() !! call mycomm%init() !! if (.not. mycomm%master) then - !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%iproc, "!" - !! call mpifx_send(mycomm, msg, mycomm%imaster) + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + !! call mpifx_send(mycomm, msg, mycomm%masterrank) !! else !! write(*, "(A)") "Master node:" - !! do source = 1, mycomm%nproc - 1 + !! do source = 1, mycomm%size - 1 !! call mpifx_recv(mycomm, msg, source) !! write(*,"(A,A)") "Message received: ", trim(msg) !! end do diff --git a/test/test_bcast.f90 b/test/test_bcast.f90 index 443bf45..16ed6e0 100644 --- a/test/test_bcast.f90 +++ b/test/test_bcast.f90 @@ -15,56 +15,56 @@ program test_bcast call mpifx_init() call mycomm%init() buffer(:) = 0 - print "(A,I2.2,A,3I5)", "CHK01:", mycomm%iproc, ":", buffer + print "(A,I2.2,A,3I5)", "CHK01:", mycomm%rank, ":", buffer if (mycomm%master) then buffer(:) = [ 1, 2, 3 ] end if - print "(A,I2.2,A,3I5)", "CHK02:", mycomm%iproc, ":", buffer + print "(A,I2.2,A,3I5)", "CHK02:", mycomm%rank, ":", buffer call mpifx_bcast(mycomm, buffer) - print "(A,I2.2,A,3I5)", "CHK03:", mycomm%iproc, ":", 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%iproc, ":", lbuffer + print "(A,I2.2,A,3L5)", "CHK04:", mycomm%rank, ":", lbuffer if (mycomm%master) then lbuffer(:) = [ .true., .false., .true. ] end if - print "(A,I2.2,A,3L5)", "CHK05:", mycomm%iproc, ":", lbuffer + print "(A,I2.2,A,3L5)", "CHK05:", mycomm%rank, ":", lbuffer call mpifx_bcast(mycomm, lbuffer) - print "(A,I2.2,A,3L5)", "CHK06:", mycomm%iproc, ":", 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%iproc, ":", rbuffer + print "(A,I2.2,A,4F10.6)", "CHK07:", mycomm%rank, ":", rbuffer if (mycomm%master) then rbuffer(:,:) = reshape([ real(dp) :: 1, 2, 3, 4 ], [ 2, 2 ]) end if - print "(A,I2.2,A,4F10.6)", "CHK08:", mycomm%iproc, ":", rbuffer + 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%iproc, ":", 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%iproc, ":", cbuffer + print "(A,I2.2,A,2F10.6)", "CHK10:", mycomm%rank, ":", cbuffer if (mycomm%master) then cbuffer = cmplx(-1, 1, sp) end if - print "(A,I2.2,A,2F10.6)", "CHK11:", mycomm%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%iproc, ":", cbuffer + print "(A,I2.2,A,2F10.6)", "CHK12:", mycomm%rank, ":", cbuffer ! Character text = " " - print "(A,I2.2,A,A6)", "CHK13:", mycomm%iproc, ":", text + print "(A,I2.2,A,A6)", "CHK13:", mycomm%rank, ":", text if (mycomm%master) then text = "hello" end if - print "(A,I2.2,A,A6)", "CHK14:", mycomm%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%iproc, ":", 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 index 33c22ae..c4ff878 100644 --- a/test/test_comm_split.f90 +++ b/test/test_comm_split.f90 @@ -7,11 +7,11 @@ program test_comm_split call mpifx_init() call allproc%init() - groupsize = allproc%nproc / 2 - mygroup = allproc%iproc / groupsize - call allproc%split(mygroup, allproc%iproc, groupproc) - write(*, "(3(A,1X,I0,1X))") "GLOBAL ID:", allproc%iproc, "SUBGROUP", & - & mygroup, "SUBGROUP ID", groupproc%iproc + 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_reduce.f90 b/test/test_reduce.f90 index 7662463..cde72fd 100644 --- a/test/test_reduce.f90 +++ b/test/test_reduce.f90 @@ -11,18 +11,18 @@ program test_reduce call mpifx_init() call mycomm%init() - vali0 = mycomm%iproc * 2 - write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%iproc, & + 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%iproc, & + write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%rank, & & "Obtained result (sum):", resvali0 - valr(:) = [ real(mycomm%iproc + 1, dp) * 1.2, & - & real(mycomm%iproc + 1, dp) * 4.3, real(mycomm%iproc + 1, dp) * 3.8 ] - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%iproc, & + 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_reduce(mycomm, valr, resvalr, MPI_PROD) - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%iproc, & + write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & & "Obtained result (prod):", resvalr(:) call mpifx_finalize() diff --git a/test/test_send_recv.f90 b/test/test_send_recv.f90 index 045c886..d86711b 100644 --- a/test/test_send_recv.f90 +++ b/test/test_send_recv.f90 @@ -9,11 +9,11 @@ program test_send_recv call mpifx_init() call mycomm%init() if (.not. mycomm%master) then - write(msg, "(A,I0,A)") "Hello from process ", mycomm%iproc, "!" - call mpifx_send(mycomm, msg, mycomm%imaster) + write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + call mpifx_send(mycomm, msg, mycomm%masterrank) else write(*, "(A)") "Master node:" - do source = 1, mycomm%nproc - 1 + do source = 1, mycomm%size - 1 call mpifx_recv(mycomm, msg, source) write(*,"(A,A)") "Message received: ", trim(msg) end do From 6ff372434f3b24173331b2d2f8b27c1006de4927 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Thu, 22 Aug 2013 20:34:41 +0200 Subject: [PATCH 03/72] Implemented wrappers for MPI_GATHER, MPI_ALLGATHER, MPI_SCATTER, MPI_REDUCE. --- make.arch.template | 2 +- src/Makefile.lib | 19 +- src/common.m4 | 28 -- src/libmpifx.F90 | 6 +- src/mpi_constants.m4 | 1 - src/mpifx_abort.m4 | 2 +- src/mpifx_allgather.F90 | 248 +++++++++++++++++ src/mpifx_allgather.m4 | 75 +++++ src/mpifx_allreduce.F90 | 150 ++++++++++ src/mpifx_allreduce.m4 | 34 +++ src/mpifx_barrier.m4 | 2 +- src/mpifx_bcast.m4 | 2 +- src/mpifx_comm.m4 | 2 +- src/mpifx_common.m4 | 2 +- ...{mpi_constants.F90 => mpifx_constants.F90} | 6 +- src/mpifx_constants.m4 | 0 src/mpifx_finalize.m4 | 2 +- src/mpifx_gather.F90 | 259 ++++++++++++++++++ src/mpifx_gather.m4 | 82 ++++++ src/mpifx_helper.F90 | 20 +- src/mpifx_helper.m4 | 47 +++- src/mpifx_init.m4 | 2 +- src/mpifx_recv.m4 | 2 +- src/mpifx_reduce.m4 | 2 +- src/mpifx_scatter.F90 | 254 +++++++++++++++++ src/mpifx_scatter.m4 | 82 ++++++ src/mpifx_send.m4 | 2 +- test/GNUmakefile | 3 +- test/test_allgather.f90 | 54 ++++ test/test_allreduce.f90 | 29 ++ test/test_gather.f90 | 72 +++++ test/test_scatter.f90 | 66 +++++ 32 files changed, 1503 insertions(+), 54 deletions(-) delete mode 100644 src/common.m4 delete mode 100644 src/mpi_constants.m4 create mode 100644 src/mpifx_allgather.F90 create mode 100644 src/mpifx_allgather.m4 create mode 100644 src/mpifx_allreduce.F90 create mode 100644 src/mpifx_allreduce.m4 rename src/{mpi_constants.F90 => mpifx_constants.F90} (72%) create mode 100644 src/mpifx_constants.m4 create mode 100644 src/mpifx_gather.F90 create mode 100644 src/mpifx_gather.m4 create mode 100644 src/mpifx_scatter.F90 create mode 100644 src/mpifx_scatter.m4 create mode 100644 test/test_allgather.f90 create mode 100644 test/test_allreduce.f90 create mode 100644 test/test_gather.f90 create mode 100644 test/test_scatter.f90 diff --git a/make.arch.template b/make.arch.template index d04379f..229eca3 100644 --- a/make.arch.template +++ b/make.arch.template @@ -17,5 +17,5 @@ LNOPT = # M4 interpreter M4 = m4 -# M4 interpreter options +# M4 interpreter options (e.g. -DDEBUG for debug mode) M4OPT = "" diff --git a/src/Makefile.lib b/src/Makefile.lib index 084ce8e..1a57969 100644 --- a/src/Makefile.lib +++ b/src/Makefile.lib @@ -8,7 +8,7 @@ # 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. +# else. You may also use the -D option to define macros (e.g. DEBUG) # VPATH: The path to this directory, if you invoke the makefile from # somewhere else. # @@ -19,7 +19,8 @@ FILENAMES = libmpifx mpifx_helper mpifx_comm mpifx_common mpifx_barrier \ mpifx_bcast mpifx_send mpifx_recv mpifx_abort mpifx_init mpifx_finalize \ - mpifx_reduce mpi_constants + mpifx_reduce mpifx_allreduce mpifx_constants mpifx_gather mpifx_allgather \ + mpifx_scatter TARGETLIB = libmpifx.a $(TARGETLIB): $(patsubst %,%.o,$(FILENAMES)) @@ -43,22 +44,26 @@ realclean: clean # Explicit dependencies -libmpifx.o: mpi_constants.o mpifx_comm.o mpifx_abort.o mpifx_barrier.o \ +libmpifx.o: mpifx_comm.o mpifx_abort.o mpifx_barrier.o \ mpifx_bcast.o mpifx_finalize.o mpifx_init.o mpifx_send.o mpifx_recv.o \ - mpifx_reduce.o + mpifx_reduce.o mpifx_allreduce.o mpifx_constants.o mpifx_gather.o \ + mpifx_allgather.o mpifx_scatter.o mpifx_abort.o: mpifx_common.o mpifx_barrier.o: mpifx_common.o mpifx_bcast.o: mpifx_common.o mpifx_comm.o: mpifx_helper.o mpifx_common.o: mpifx_helper.o mpifx_comm.o -mpi_constants.o: +mpifx_constants.o: mpifx_finalize.o: mpifx_common.o mpifx_helper.o: mpifx_init.o: mpifx_common.o -mpifx_reduce.o: mpifx_common.o mpifx_common.o +mpifx_reduce.o: mpifx_common.o +mpifx_allreduce.o: mpifx_common.o mpifx_send.o: mpifx_common.o mpifx_recv.o: mpifx_common.o - +mpifx_gather.o: mpifx_common.o +mpifx_allgather.o: mpifx_common.o +mpifx_scatter.o: mpifx_common.o ### Local Variables: ### mode:makefile 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 index 9e3b431..f9e02c3 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -1,7 +1,7 @@ !> \mainpage Fortran 2003 wrappers around MPI routines !! module libmpifx_module - use mpi_constants_module + use mpifx_constants_module use mpifx_comm_module use mpifx_abort_module use mpifx_barrier_module @@ -11,6 +11,10 @@ module libmpifx_module use mpifx_send_module use mpifx_recv_module use mpifx_reduce_module + use mpifx_allreduce_module + use mpifx_gather_module + use mpifx_allgather_module + use mpifx_scatter_module implicit none public diff --git a/src/mpi_constants.m4 b/src/mpi_constants.m4 deleted file mode 100644 index 8878874..0000000 --- a/src/mpi_constants.m4 +++ /dev/null @@ -1 +0,0 @@ -include(common.m4) diff --git a/src/mpifx_abort.m4 b/src/mpifx_abort.m4 index 8878874..40a7479 100644 --- a/src/mpifx_abort.m4 +++ b/src/mpifx_abort.m4 @@ -1 +1 @@ -include(common.m4) +include(mpifx_common.m4) diff --git a/src/mpifx_allgather.F90 b/src/mpifx_allgather.F90 new file mode 100644 index 0000000..4df5301 --- /dev/null +++ b/src/mpifx_allgather.F90 @@ -0,0 +1,248 @@ +include(mpifx_allgather.m4) + +!> 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. + !! + !! \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 that case + !! the last dimension of it must be of the size of the number of processes + !! in the gathering. + !! + !! \see MPI documentation (\c MPI_ALLGATHER) + !! + !! 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 + module procedure & + & mpifx_allgather_i1i1, mpifx_allgather_i2i2, mpifx_allgather_i3i3, & + & mpifx_allgather_i4i4, mpifx_allgather_i5i5, mpifx_allgather_i6i6 + module procedure & + & mpifx_allgather_i0i1, mpifx_allgather_i1i2, mpifx_allgather_i2i3, & + & mpifx_allgather_i3i4, mpifx_allgather_i4i5, mpifx_allgather_i5i6 + module procedure & + & mpifx_allgather_s1s1, mpifx_allgather_s2s2, mpifx_allgather_s3s3, & + & mpifx_allgather_s4s4, mpifx_allgather_s5s5, mpifx_allgather_s6s6 + module procedure & + & mpifx_allgather_s0s1, mpifx_allgather_s1s2, mpifx_allgather_s2s3, & + & mpifx_allgather_s3s4, mpifx_allgather_s4s5, mpifx_allgather_s5s6 + module procedure & + & mpifx_allgather_d1d1, mpifx_allgather_d2d2, mpifx_allgather_d3d3, & + & mpifx_allgather_d4d4, mpifx_allgather_d5d5, mpifx_allgather_d6d6 + module procedure & + & mpifx_allgather_d0d1, mpifx_allgather_d1d2, mpifx_allgather_d2d3, & + & mpifx_allgather_d3d4, mpifx_allgather_d4d5, mpifx_allgather_d5d6 + module procedure & + & mpifx_allgather_c1c1, mpifx_allgather_c2c2, mpifx_allgather_c3c3, & + & mpifx_allgather_c4c4, mpifx_allgather_c5c5, mpifx_allgather_c6c6 + module procedure & + & mpifx_allgather_c0c1, mpifx_allgather_c1c2, mpifx_allgather_c2c3, & + & mpifx_allgather_c3c4, mpifx_allgather_c4c5, mpifx_allgather_c5c6 + module procedure & + & mpifx_allgather_z1z1, mpifx_allgather_z2z2, mpifx_allgather_z3z3, & + & mpifx_allgather_z4z4, mpifx_allgather_z5z5, mpifx_allgather_z6z6 + module procedure & + & mpifx_allgather_z0z1, mpifx_allgather_z1z2, mpifx_allgather_z2z3, & + & mpifx_allgather_z3z4, mpifx_allgather_z4z5, mpifx_allgather_z5z6 + module procedure & + & mpifx_allgather_l1l1, mpifx_allgather_l2l2, mpifx_allgather_l3l3, & + & mpifx_allgather_l4l4, mpifx_allgather_l5l5, mpifx_allgather_l6l6 + module procedure & + & mpifx_allgather_l0l1, mpifx_allgather_l1l2, mpifx_allgather_l2l3, & + & mpifx_allgather_l3l4, mpifx_allgather_l4l5, mpifx_allgather_l5l6 + end interface mpifx_allgather + + +contains + + _subroutine_mpifx_allgather_dr0(i1i1, integer, (:), 1, MPI_INTEGER) + _subroutine_mpifx_allgather_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) + _subroutine_mpifx_allgather_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + _subroutine_mpifx_allgather_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + _subroutine_mpifx_allgather_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_allgather_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + _subroutine_mpifx_allgather_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) + _subroutine_mpifx_allgather_dr1(i1i2, integer, (:), size(send), (:,:), 2, + MPI_INTEGER) + _subroutine_mpifx_allgather_dr1(i2i3, integer, (:,:), size(send), (:,:,:), 3, + MPI_INTEGER) + _subroutine_mpifx_allgather_dr1(i3i4, integer, (:,:,:), size(send), (:,:,:,:), + 4, MPI_INTEGER) + _subroutine_mpifx_allgather_dr1(i4i5, integer, (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_allgather_dr1(i5i6, integer, (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_INTEGER) + + + _subroutine_mpifx_allgather_dr0(s1s1, real(sp), (:), 1, MPI_REAL) + _subroutine_mpifx_allgather_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) + _subroutine_mpifx_allgather_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + _subroutine_mpifx_allgather_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + _subroutine_mpifx_allgather_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_allgather_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + _subroutine_mpifx_allgather_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) + _subroutine_mpifx_allgather_dr1(s1s2, real(sp), (:), size(send), (:,:), 2, + MPI_REAL) + _subroutine_mpifx_allgather_dr1(s2s3, real(sp), (:,:), size(send), (:,:,:), + 3, MPI_REAL) + _subroutine_mpifx_allgather_dr1(s3s4, real(sp), (:,:,:), size(send), + (:,:,:,:), 4, MPI_REAL) + _subroutine_mpifx_allgather_dr1(s4s5, real(sp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_allgather_dr1(s5s6, real(sp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_REAL) + + + _subroutine_mpifx_allgather_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr0(d2d2, real(dp), (:,:), 2, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr0(d3d3, real(dp), (:,:,:), 3, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr0(d4d4, real(dp), (:,:,:,:), 4, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr0(d5d5, real(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_allgather_dr1(d0d1, real(dp), , 1, (:), 1, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr1(d1d2, real(dp), (:), size(send), (:,:), 2, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr1(d2d3, real(dp), (:,:), size(send), (:,:,:), + 3, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr1(d3d4, real(dp), (:,:,:), size(send), + (:,:,:,:), 4, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr1(d4d5, real(dp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgather_dr1(d5d6, real(dp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) + + + _subroutine_mpifx_allgather_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, + MPI_COMPLEX) + _subroutine_mpifx_allgather_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, + MPI_COMPLEX) + + _subroutine_mpifx_allgather_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr1(c1c2, complex(sp), (:), size(send), (:,:), 2, + MPI_COMPLEX) + _subroutine_mpifx_allgather_dr1(c2c3, complex(sp), (:,:), size(send), + (:,:,:), 3, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr1(c3c4, complex(sp), (:,:,:), size(send), + (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr1(c4c5, complex(sp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_allgather_dr1(c5c6, complex(sp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + _subroutine_mpifx_allgather_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr0(z2z2, complex(dp), (:,:), 2, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr0(z3z3, complex(dp), (:,:,:), 3, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr0(z4z4, complex(dp), (:,:,:,:), 4, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_allgather_dr1(z0z1, complex(dp), , 1, (:), 1, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr1(z1z2, complex(dp), (:), size(send), (:,:), 2, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr1(z2z3, complex(dp), (:,:), size(send), (:,:,:), + 3, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr1(z3z4, complex(dp), (:,:,:), size(send), + (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr1(z4z5, complex(dp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgather_dr1(z5z6, complex(dp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) + + + _subroutine_mpifx_allgather_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + _subroutine_mpifx_allgather_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr1(l1l2, logical, (:), size(send), (:,:), 2, + MPI_LOGICAL) + _subroutine_mpifx_allgather_dr1(l2l3, logical, (:,:), size(send), (:,:,:), 3, + MPI_LOGICAL) + _subroutine_mpifx_allgather_dr1(l3l4, logical, (:,:,:), size(send), (:,:,:,:), + 4, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr1(l4l5, logical, (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_allgather_dr1(l5l6, logical, (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_LOGICAL) + + +end module mpifx_allgather_module diff --git a/src/mpifx_allgather.m4 b/src/mpifx_allgather.m4 new file mode 100644 index 0000000..2dd0771 --- /dev/null +++ b/src/mpifx_allgather.m4 @@ -0,0 +1,75 @@ +include(mpifx_common.m4) + +dnl ************************************************************************ +dnl *** mpifx_allgather +dnl ************************************************************************ + +define(`_subroutine_mpifx_allgather_dr0',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send/recv buffer rank (1, 2, etc.) +dnl $5: corresponding MPI type +dnl +!> Gathers results on all processes (type $1). +!! +!! \param mycomm MPI communicator. +!! \param send Quantity to be sent for gathering. +!! \param recv Received data. +!! \param error Error code on exit. +!! +subroutine mpifx_allgather_$1(mycomm, send, recv, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$3 + integer, intent(out), optional :: error + + integer :: error0 + + _assert(size(recv) == size(send) * mycomm%size) + _assert(size(recv, dim=$4) == size(send, dim=$4) * mycomm%size) + + call mpi_allgather(send, size(send), $5, recv, size(send), & + & $5, mycomm%id, error0) + call handle_errorflag(error0, "MPI_ALLGATHER in mpifx_allgather_$1", error) + +end subroutine mpifx_allgather_$1 +') + + +define(`_subroutine_mpifx_allgather_dr1',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send buffer size (1 or size(send)) +dnl $5: recv buffer rank specifier ((:), (:,:), etc.) +dnl $6: recv buffers rank (1, 2, etc.) +dnl $7: corresponding MPI type +dnl +!> Gathers results on all processes (type $1). +!! +!! \param mycomm MPI communicator. +!! \param send Quantity to be sent for gathering. +!! \param recv Received data. +!! \param error Error code on exit. +!! +subroutine mpifx_allgather_$1(mycomm, send, recv, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$5 + integer, intent(out), optional :: error + + integer :: error0 + + _assert(size(recv) == $4 * mycomm%size) + _assert(size(recv, dim=$6) == mycomm%size) + + call mpi_allgather(send, $4, $7, recv, $4, & + & $7, mycomm%id, error0) + call handle_errorflag(error0, "MPI_ALLGATHER in mpifx_allgather_$1", error) + +end subroutine mpifx_allgather_$1 + +') diff --git a/src/mpifx_allreduce.F90 b/src/mpifx_allreduce.F90 new file mode 100644 index 0000000..d4394de --- /dev/null +++ b/src/mpifx_allreduce.F90 @@ -0,0 +1,150 @@ +include(mpifx_allreduce.m4) + +!> Contains wrapper for \c MPI_ALLREDUCE. +module mpifx_allreduce_module + use mpifx_common_module + implicit none + private + + public :: mpifx_allreduce + + !> 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 + module procedure & + & mpifx_allreduce_i0, mpifx_allreduce_i1, mpifx_allreduce_i2, & + & mpifx_allreduce_i3, mpifx_allreduce_i4, mpifx_allreduce_i5, & + & mpifx_allreduce_i6 + module procedure & + & mpifx_allreduce_s0, mpifx_allreduce_s1, mpifx_allreduce_s2, & + & mpifx_allreduce_s3, mpifx_allreduce_s4, mpifx_allreduce_s5, & + & mpifx_allreduce_s6 + module procedure & + & mpifx_allreduce_d0, mpifx_allreduce_d1, mpifx_allreduce_d2, & + & mpifx_allreduce_d3, mpifx_allreduce_d4, mpifx_allreduce_d5, & + & mpifx_allreduce_d6 + module procedure & + & mpifx_allreduce_c0, mpifx_allreduce_c1, mpifx_allreduce_c2, & + & mpifx_allreduce_c3, mpifx_allreduce_c4, mpifx_allreduce_c5, & + & mpifx_allreduce_c6 + module procedure & + & mpifx_allreduce_z0, mpifx_allreduce_z1, mpifx_allreduce_z2, & + & mpifx_allreduce_z3, mpifx_allreduce_z4, mpifx_allreduce_z5, & + & mpifx_allreduce_z6 + module procedure & + & mpifx_allreduce_l0, mpifx_allreduce_l1, mpifx_allreduce_l2, & + & mpifx_allreduce_l3, mpifx_allreduce_l4, mpifx_allreduce_l5, & + & mpifx_allreduce_l6 + end interface + +contains + + _subroutine_mpifx_allreduce(i0, integer, , 1, MPI_INTEGER) + _subroutine_mpifx_allreduce(i1, integer, (:), size(operand), MPI_INTEGER) + _subroutine_mpifx_allreduce(i2, integer, (:,:), size(operand), MPI_INTEGER) + _subroutine_mpifx_allreduce(i3, integer, (:,:,:), size(operand), MPI_INTEGER) + _subroutine_mpifx_allreduce(i4, integer, (:,:,:,:), size(operand), + MPI_INTEGER) + _subroutine_mpifx_allreduce(i5, integer, (:,:,:,:,:), size(operand), + MPI_INTEGER) + _subroutine_mpifx_allreduce(i6, integer, (:,:,:,:,:,:), size(operand), + MPI_INTEGER) + + _subroutine_mpifx_allreduce(s0, real(sp), , 1, MPI_REAL) + _subroutine_mpifx_allreduce(s1, real(sp), (:), size(operand), MPI_REAL) + _subroutine_mpifx_allreduce(s2, real(sp), (:,:), size(operand), MPI_REAL) + _subroutine_mpifx_allreduce(s3, real(sp), (:,:,:), size(operand), MPI_REAL) + _subroutine_mpifx_allreduce(s4, real(sp), (:,:,:,:), size(operand), MPI_REAL) + _subroutine_mpifx_allreduce(s5, real(sp), (:,:,:,:,:), size(operand), + MPI_REAL) + _subroutine_mpifx_allreduce(s6, real(sp), (:,:,:,:,:,:), size(operand), + MPI_REAL) + + _subroutine_mpifx_allreduce(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduce(d1, real(dp), (:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduce(d2, real(dp), (:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduce(d3, real(dp), (:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduce(d4, real(dp), (:,:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduce(d5, real(dp), (:,:,:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduce(d6, real(dp), (:,:,:,:,:,:), size(operand), + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_allreduce(c0, complex(sp), , 1, MPI_COMPLEX) + _subroutine_mpifx_allreduce(c1, complex(sp), (:), size(operand), MPI_COMPLEX) + _subroutine_mpifx_allreduce(c2, complex(sp), (:,:), size(operand), + MPI_COMPLEX) + _subroutine_mpifx_allreduce(c3, complex(sp), (:,:,:), size(operand), + MPI_COMPLEX) + _subroutine_mpifx_allreduce(c4, complex(sp), (:,:,:,:), size(operand), + MPI_COMPLEX) + _subroutine_mpifx_allreduce(c5, complex(sp), (:,:,:,:,:), size(operand), + MPI_COMPLEX) + _subroutine_mpifx_allreduce(c6, complex(sp), (:,:,:,:,:,:), size(operand), + MPI_COMPLEX) + + _subroutine_mpifx_allreduce(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduce(z1, complex(dp), (:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduce(z2, complex(dp), (:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduce(z3, complex(dp), (:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduce(z4, complex(dp), (:,:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduce(z5, complex(dp), (:,:,:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduce(z6, complex(dp), (:,:,:,:,:,:), size(operand), + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_allreduce(l0, logical, , 1, MPI_LOGICAL) + _subroutine_mpifx_allreduce(l1, logical, (:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_allreduce(l2, logical, (:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_allreduce(l3, logical, (:,:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_allreduce(l4, logical, (:,:,:,:), size(operand), + MPI_LOGICAL) + _subroutine_mpifx_allreduce(l5, logical, (:,:,:,:,:), size(operand), + MPI_LOGICAL) + _subroutine_mpifx_allreduce(l6, logical, (:,:,:,:,:,:), size(operand), + MPI_LOGICAL) + + +end module mpifx_allreduce_module diff --git a/src/mpifx_allreduce.m4 b/src/mpifx_allreduce.m4 new file mode 100644 index 0000000..1737f31 --- /dev/null +++ b/src/mpifx_allreduce.m4 @@ -0,0 +1,34 @@ +include(mpifx_common.m4) + +dnl ************************************************************************ +dnl *** mpifx_allreduce +dnl ************************************************************************ + +define(`_subroutine_mpifx_allreduce',`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 +!> Reduces results on all processes (type $1). +!! +!! \param mycomm MPI communicator. +!! \param operand Quantity to be reduced. +!! \param result Contains result on exit. +!! \param operator Reduction operator +!! \param error Error code on exit. +!! +subroutine mpifx_allreduce_$1(mycomm, operand, result, operator, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: operand$3 + $2, intent(inout) :: result$3 + integer, intent(in) :: operator + integer, intent(out), optional :: error + + integer :: error0 + + call mpi_allreduce(operand, result, $4, $5, operator, mycomm%id, error0) + call handle_errorflag(error0, "MPI_ALLREDUCE in mpifx_allreduce_$1", error) + +end subroutine mpifx_allreduce_$1 +') diff --git a/src/mpifx_barrier.m4 b/src/mpifx_barrier.m4 index 8878874..40a7479 100644 --- a/src/mpifx_barrier.m4 +++ b/src/mpifx_barrier.m4 @@ -1 +1 @@ -include(common.m4) +include(mpifx_common.m4) diff --git a/src/mpifx_bcast.m4 b/src/mpifx_bcast.m4 index 05f3cab..3dc599d 100644 --- a/src/mpifx_bcast.m4 +++ b/src/mpifx_bcast.m4 @@ -1,4 +1,4 @@ -include(common.m4) +include(mpifx_common.m4) dnl ************************************************************************ dnl *** mpifx_bcast diff --git a/src/mpifx_comm.m4 b/src/mpifx_comm.m4 index 8878874..3b8c873 100644 --- a/src/mpifx_comm.m4 +++ b/src/mpifx_comm.m4 @@ -1 +1 @@ -include(common.m4) +include(mpifx_helper.m4) diff --git a/src/mpifx_common.m4 b/src/mpifx_common.m4 index 8878874..3b8c873 100644 --- a/src/mpifx_common.m4 +++ b/src/mpifx_common.m4 @@ -1 +1 @@ -include(common.m4) +include(mpifx_helper.m4) diff --git a/src/mpi_constants.F90 b/src/mpifx_constants.F90 similarity index 72% rename from src/mpi_constants.F90 rename to src/mpifx_constants.F90 index 69b8d03..3b9c723 100644 --- a/src/mpi_constants.F90 +++ b/src/mpifx_constants.F90 @@ -1,8 +1,8 @@ -include(mpi_constants.m4) +include(mpifx_constants.m4) !> Exports some MPI constants. !! \cond HIDDEN -module mpi_constants_module +module mpifx_constants_module use mpi private @@ -10,6 +10,6 @@ module mpi_constants_module public :: MPI_LAND, MPI_BAND, MPI_LOR, MPI_BOR, MPI_LXOR ,MPI_BXOR public :: MPI_MAXLOC, MPI_MINLOC -end module mpi_constants_module +end module mpifx_constants_module !> \endcond diff --git a/src/mpifx_constants.m4 b/src/mpifx_constants.m4 new file mode 100644 index 0000000..e69de29 diff --git a/src/mpifx_finalize.m4 b/src/mpifx_finalize.m4 index 8878874..40a7479 100644 --- a/src/mpifx_finalize.m4 +++ b/src/mpifx_finalize.m4 @@ -1 +1 @@ -include(common.m4) +include(mpifx_common.m4) diff --git a/src/mpifx_gather.F90 b/src/mpifx_gather.F90 new file mode 100644 index 0000000..168fa2d --- /dev/null +++ b/src/mpifx_gather.F90 @@ -0,0 +1,259 @@ +include(mpifx_gather.m4) + +!> 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%master) 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%master) 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%master) 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%master) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! ! I1 -> I2 + !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + !! if (mycomm%master) 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%master) then + !! write(*, *) mycomm%rank, "Recv2 buffer:", recv2 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_gather + !! + interface mpifx_gather + module procedure & + & mpifx_gather_i1i1, mpifx_gather_i2i2, mpifx_gather_i3i3, & + & mpifx_gather_i4i4, mpifx_gather_i5i5, mpifx_gather_i6i6 + module procedure & + & mpifx_gather_i0i1, mpifx_gather_i1i2, mpifx_gather_i2i3, & + & mpifx_gather_i3i4, mpifx_gather_i4i5, mpifx_gather_i5i6 + module procedure & + & mpifx_gather_s1s1, mpifx_gather_s2s2, mpifx_gather_s3s3, & + & mpifx_gather_s4s4, mpifx_gather_s5s5, mpifx_gather_s6s6 + module procedure & + & mpifx_gather_s0s1, mpifx_gather_s1s2, mpifx_gather_s2s3, & + & mpifx_gather_s3s4, mpifx_gather_s4s5, mpifx_gather_s5s6 + module procedure & + & mpifx_gather_d1d1, mpifx_gather_d2d2, mpifx_gather_d3d3, & + & mpifx_gather_d4d4, mpifx_gather_d5d5, mpifx_gather_d6d6 + module procedure & + & mpifx_gather_d0d1, mpifx_gather_d1d2, mpifx_gather_d2d3, & + & mpifx_gather_d3d4, mpifx_gather_d4d5, mpifx_gather_d5d6 + module procedure & + & mpifx_gather_c1c1, mpifx_gather_c2c2, mpifx_gather_c3c3, & + & mpifx_gather_c4c4, mpifx_gather_c5c5, mpifx_gather_c6c6 + module procedure & + & mpifx_gather_c0c1, mpifx_gather_c1c2, mpifx_gather_c2c3, & + & mpifx_gather_c3c4, mpifx_gather_c4c5, mpifx_gather_c5c6 + module procedure & + & mpifx_gather_z1z1, mpifx_gather_z2z2, mpifx_gather_z3z3, & + & mpifx_gather_z4z4, mpifx_gather_z5z5, mpifx_gather_z6z6 + module procedure & + & mpifx_gather_z0z1, mpifx_gather_z1z2, mpifx_gather_z2z3, & + & mpifx_gather_z3z4, mpifx_gather_z4z5, mpifx_gather_z5z6 + module procedure & + & mpifx_gather_l1l1, mpifx_gather_l2l2, mpifx_gather_l3l3, & + & mpifx_gather_l4l4, mpifx_gather_l5l5, mpifx_gather_l6l6 + module procedure & + & mpifx_gather_l0l1, mpifx_gather_l1l2, mpifx_gather_l2l3, & + & mpifx_gather_l3l4, mpifx_gather_l4l5, mpifx_gather_l5l6 + end interface mpifx_gather + + +contains + + _subroutine_mpifx_gather_dr0(i1i1, integer, (:), 1, MPI_INTEGER) + _subroutine_mpifx_gather_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) + _subroutine_mpifx_gather_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + _subroutine_mpifx_gather_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + _subroutine_mpifx_gather_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_gather_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + _subroutine_mpifx_gather_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) + _subroutine_mpifx_gather_dr1(i1i2, integer, (:), size(send), (:,:), 2, + MPI_INTEGER) + _subroutine_mpifx_gather_dr1(i2i3, integer, (:,:), size(send), (:,:,:), 3, + MPI_INTEGER) + _subroutine_mpifx_gather_dr1(i3i4, integer, (:,:,:), size(send), (:,:,:,:), + 4, MPI_INTEGER) + _subroutine_mpifx_gather_dr1(i4i5, integer, (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_gather_dr1(i5i6, integer, (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_INTEGER) + + + _subroutine_mpifx_gather_dr0(s1s1, real(sp), (:), 1, MPI_REAL) + _subroutine_mpifx_gather_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) + _subroutine_mpifx_gather_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + _subroutine_mpifx_gather_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + _subroutine_mpifx_gather_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_gather_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + _subroutine_mpifx_gather_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) + _subroutine_mpifx_gather_dr1(s1s2, real(sp), (:), size(send), (:,:), 2, + MPI_REAL) + _subroutine_mpifx_gather_dr1(s2s3, real(sp), (:,:), size(send), (:,:,:), 3, + MPI_REAL) + _subroutine_mpifx_gather_dr1(s3s4, real(sp), (:,:,:), size(send), (:,:,:,:), + 4, MPI_REAL) + _subroutine_mpifx_gather_dr1(s4s5, real(sp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_gather_dr1(s5s6, real(sp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_REAL) + + + _subroutine_mpifx_gather_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr0(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr0(d4d4, real(dp), (:,:,:,:), 4, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr0(d5d5, real(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_gather_dr1(d0d1, real(dp), , 1, (:), 1, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr1(d1d2, real(dp), (:), size(send), (:,:), 2, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr1(d2d3, real(dp), (:,:), size(send), (:,:,:), 3, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr1(d3d4, real(dp), (:,:,:), size(send), (:,:,:,:), + 4, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr1(d4d5, real(dp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gather_dr1(d5d6, real(dp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) + + + _subroutine_mpifx_gather_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + _subroutine_mpifx_gather_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + _subroutine_mpifx_gather_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + _subroutine_mpifx_gather_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_gather_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_gather_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) + + _subroutine_mpifx_gather_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) + _subroutine_mpifx_gather_dr1(c1c2, complex(sp), (:), size(send), (:,:), 2, + MPI_COMPLEX) + _subroutine_mpifx_gather_dr1(c2c3, complex(sp), (:,:), size(send), (:,:,:), + 3, MPI_COMPLEX) + _subroutine_mpifx_gather_dr1(c3c4, complex(sp), (:,:,:), size(send), + (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_gather_dr1(c4c5, complex(sp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_gather_dr1(c5c6, complex(sp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + _subroutine_mpifx_gather_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr0(z3z3, complex(dp), (:,:,:), 3, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr0(z4z4, complex(dp), (:,:,:,:), 4, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_gather_dr1(z0z1, complex(dp), , 1, (:), 1, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr1(z1z2, complex(dp), (:), size(send), (:,:), 2, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr1(z2z3, complex(dp), (:,:), size(send), (:,:,:), + 3, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr1(z3z4, complex(dp), (:,:,:), size(send), + (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr1(z4z5, complex(dp), (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gather_dr1(z5z6, complex(dp), (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) + + + _subroutine_mpifx_gather_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_gather_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) + _subroutine_mpifx_gather_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + _subroutine_mpifx_gather_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + _subroutine_mpifx_gather_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_gather_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + _subroutine_mpifx_gather_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_gather_dr1(l1l2, logical, (:), size(send), (:,:), 2, + MPI_LOGICAL) + _subroutine_mpifx_gather_dr1(l2l3, logical, (:,:), size(send), (:,:,:), 3, + MPI_LOGICAL) + _subroutine_mpifx_gather_dr1(l3l4, logical, (:,:,:), size(send), (:,:,:,:), + 4, MPI_LOGICAL) + _subroutine_mpifx_gather_dr1(l4l5, logical, (:,:,:,:), size(send), + (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_gather_dr1(l5l6, logical, (:,:,:,:,:), size(send), + (:,:,:,:,:,:), 6, MPI_LOGICAL) + + +end module mpifx_gather_module diff --git a/src/mpifx_gather.m4 b/src/mpifx_gather.m4 new file mode 100644 index 0000000..353f4ef --- /dev/null +++ b/src/mpifx_gather.m4 @@ -0,0 +1,82 @@ +include(mpifx_common.m4) + +dnl ************************************************************************ +dnl *** mpifx_gather +dnl ************************************************************************ + +define(`_subroutine_mpifx_gather_dr0',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send/recv buffer rank (1, 2, etc.) +dnl $5: corresponding MPI type +dnl +!> Gathers results on one process (type $1). +!! +!! \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%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_gather_$1(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$3 + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + _assert(.not. mycomm%master .or. size(recv) == size(send) * mycomm%size) + _assert(.not. mycomm%master .or. & + & size(recv, dim=$4) == size(send, dim=$4) * mycomm%size) + + _handle_inoptflag(root0, root, mycomm%masterrank) + call mpi_gather(send, size(send), $5, recv, size(send), & + & $5, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_GATHER in mpifx_gather_$1", error) + +end subroutine mpifx_gather_$1 +') + + +define(`_subroutine_mpifx_gather_dr1',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send buffer size (1 or size(send)) +dnl $5: recv buffer rank specifier ((:), (:,:), etc.) +dnl $6: recv buffers rank (1, 2, etc.) +dnl $7: corresponding MPI type +dnl +!> Gathers results on one process (type $1). +!! +!! \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%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_gather_$1(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$5 + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + _assert(.not. mycomm%master .or. size(recv) == $4 * mycomm%size) + _assert(.not. mycomm%master .or. size(recv, dim=$6) == mycomm%size) + + _handle_inoptflag(root0, root, mycomm%masterrank) + call mpi_gather(send, $4, $7, recv, $4, & + & $7, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_GATHER in mpifx_gather_$1", error) + +end subroutine mpifx_gather_$1 + +') diff --git a/src/mpifx_helper.F90 b/src/mpifx_helper.F90 index 36647ea..a160ff6 100644 --- a/src/mpifx_helper.F90 +++ b/src/mpifx_helper.F90 @@ -8,7 +8,7 @@ module mpifx_helper_module private public :: default_tag, sp, dp - public :: handle_errorflag + public :: handle_errorflag, assertfailed !> Default tag integer, parameter :: default_tag = 0 @@ -51,6 +51,24 @@ subroutine handle_errorflag(error0, msg, error) end subroutine handle_errorflag + !> Stops code signalizing failed a + subroutine assertfailed(file, line) + character(*), intent(in) :: file + integer, intent(in) :: line + + integer :: aborterror + + write(*, "(A)") "Assertion failed" + write(*, "(A,A)") "File:", file + write(*, "(A,I0)") "Line:", line + 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 subroutine assertfailed + + end module mpifx_helper_module !> \endcond diff --git a/src/mpifx_helper.m4 b/src/mpifx_helper.m4 index 8878874..8bc38af 100644 --- a/src/mpifx_helper.m4 +++ b/src/mpifx_helper.m4 @@ -1 +1,46 @@ -include(common.m4) +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 +') + +dnl Set DEBUG to 1, unless DEBUG is unspecified or explicitely set to 0. +dnl +define(`DEBUG', ifdef(`DEBUG', ifelse(DEBUG, 0, 0, 1), 0)) + +dnl Indicates debug code. +dnl $1 Code. It is only inserted, if DEBUG is defined as 1. +dnl +define(`_debug', ifelse(DEBUG, 1, $1, `')) + +dnl Removing directory part of a file +dnl +define(`basename', `patsubst($1,`.*/',`')') + +dnl Assertion +dnl $1 Condition to check (only inserted if in debug mode). +dnl +define(`_assert', _debug(`dnl +if (.not. ($1)) then + call assertfailed("`basename(__file__)'", `__line__') +end if')) diff --git a/src/mpifx_init.m4 b/src/mpifx_init.m4 index 8878874..40a7479 100644 --- a/src/mpifx_init.m4 +++ b/src/mpifx_init.m4 @@ -1 +1 @@ -include(common.m4) +include(mpifx_common.m4) diff --git a/src/mpifx_recv.m4 b/src/mpifx_recv.m4 index a555b78..93cb2b7 100644 --- a/src/mpifx_recv.m4 +++ b/src/mpifx_recv.m4 @@ -1,4 +1,4 @@ -include(common.m4) +include(mpifx_common.m4) dnl ************************************************************************ dnl *** mpifx_recv diff --git a/src/mpifx_reduce.m4 b/src/mpifx_reduce.m4 index fdeab48..ce77a92 100644 --- a/src/mpifx_reduce.m4 +++ b/src/mpifx_reduce.m4 @@ -1,4 +1,4 @@ -include(common.m4) +include(mpifx_common.m4) dnl ************************************************************************ dnl *** mpifx_reduce diff --git a/src/mpifx_scatter.F90 b/src/mpifx_scatter.F90 new file mode 100644 index 0000000..bee26de --- /dev/null +++ b/src/mpifx_scatter.F90 @@ -0,0 +1,254 @@ +include(mpifx_scatter.m4) + +!> 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%master) 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%master) 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%master) 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 + module procedure & + & mpifx_scatter_i1i1, mpifx_scatter_i2i2, mpifx_scatter_i3i3, & + & mpifx_scatter_i4i4, mpifx_scatter_i5i5, mpifx_scatter_i6i6 + module procedure & + & mpifx_scatter_i1i0, mpifx_scatter_i2i1, mpifx_scatter_i3i2, & + & mpifx_scatter_i4i3, mpifx_scatter_i5i4, mpifx_scatter_i6i5 + module procedure & + & mpifx_scatter_s1s1, mpifx_scatter_s2s2, mpifx_scatter_s3s3, & + & mpifx_scatter_s4s4, mpifx_scatter_s5s5, mpifx_scatter_s6s6 + module procedure & + & mpifx_scatter_s1s0, mpifx_scatter_s2s1, mpifx_scatter_s3s2, & + & mpifx_scatter_s4s3, mpifx_scatter_s5s4, mpifx_scatter_s6s5 + module procedure & + & mpifx_scatter_d1d1, mpifx_scatter_d2d2, mpifx_scatter_d3d3, & + & mpifx_scatter_d4d4, mpifx_scatter_d5d5, mpifx_scatter_d6d6 + module procedure & + & mpifx_scatter_d1d0, mpifx_scatter_d2d1, mpifx_scatter_d3d2, & + & mpifx_scatter_d4d3, mpifx_scatter_d5d4, mpifx_scatter_d6d5 + module procedure & + & mpifx_scatter_c1c1, mpifx_scatter_c2c2, mpifx_scatter_c3c3, & + & mpifx_scatter_c4c4, mpifx_scatter_c5c5, mpifx_scatter_c6c6 + module procedure & + & mpifx_scatter_c1c0, mpifx_scatter_c2c1, mpifx_scatter_c3c2, & + & mpifx_scatter_c4c3, mpifx_scatter_c5c4, mpifx_scatter_c6c5 + module procedure & + & mpifx_scatter_z1z1, mpifx_scatter_z2z2, mpifx_scatter_z3z3, & + & mpifx_scatter_z4z4, mpifx_scatter_z5z5, mpifx_scatter_z6z6 + module procedure & + & mpifx_scatter_z1z0, mpifx_scatter_z2z1, mpifx_scatter_z3z2, & + & mpifx_scatter_z4z3, mpifx_scatter_z5z4, mpifx_scatter_z6z5 + module procedure & + & mpifx_scatter_l1l1, mpifx_scatter_l2l2, mpifx_scatter_l3l3, & + & mpifx_scatter_l4l4, mpifx_scatter_l5l5, mpifx_scatter_l6l6 + module procedure & + & mpifx_scatter_l1l0, mpifx_scatter_l2l1, mpifx_scatter_l3l2, & + & mpifx_scatter_l4l3, mpifx_scatter_l5l4, mpifx_scatter_l6l5 + end interface mpifx_scatter + + +contains + + _subroutine_mpifx_scatter_dr0(i1i1, integer, (:), 1, MPI_INTEGER) + _subroutine_mpifx_scatter_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) + _subroutine_mpifx_scatter_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + _subroutine_mpifx_scatter_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + _subroutine_mpifx_scatter_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_scatter_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + _subroutine_mpifx_scatter_dr1(i1i0, integer, , 1, (:), 1, MPI_INTEGER) + _subroutine_mpifx_scatter_dr1(i2i1, integer, (:), size(recv), (:,:), 2, + MPI_INTEGER) + _subroutine_mpifx_scatter_dr1(i3i2, integer, (:,:), size(recv), (:,:,:), 3, + MPI_INTEGER) + _subroutine_mpifx_scatter_dr1(i4i3, integer, (:,:,:), size(recv), (:,:,:,:), + 4, MPI_INTEGER) + _subroutine_mpifx_scatter_dr1(i5i4, integer, (:,:,:,:), size(recv), + (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_scatter_dr1(i6i5, integer, (:,:,:,:,:), size(recv), + (:,:,:,:,:,:), 6, MPI_INTEGER) + + + _subroutine_mpifx_scatter_dr0(s1s1, real(sp), (:), 1, MPI_REAL) + _subroutine_mpifx_scatter_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) + _subroutine_mpifx_scatter_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + _subroutine_mpifx_scatter_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + _subroutine_mpifx_scatter_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_scatter_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + _subroutine_mpifx_scatter_dr1(s1s0, real(sp), , 1, (:), 1, MPI_REAL) + _subroutine_mpifx_scatter_dr1(s2s1, real(sp), (:), size(recv), (:,:), 2, + MPI_REAL) + _subroutine_mpifx_scatter_dr1(s3s2, real(sp), (:,:), size(recv), (:,:,:), 3, + MPI_REAL) + _subroutine_mpifx_scatter_dr1(s4s3, real(sp), (:,:,:), size(recv), (:,:,:,:), + 4, MPI_REAL) + _subroutine_mpifx_scatter_dr1(s5s4, real(sp), (:,:,:,:), size(recv), + (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_scatter_dr1(s6s5, real(sp), (:,:,:,:,:), size(recv), + (:,:,:,:,:,:), 6, MPI_REAL) + + + _subroutine_mpifx_scatter_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr0(d3d3, real(dp), (:,:,:), 3, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr0(d4d4, real(dp), (:,:,:,:), 4, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr0(d5d5, real(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_scatter_dr1(d1d0, real(dp), , 1, (:), 1, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr1(d2d1, real(dp), (:), size(recv), (:,:), 2, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr1(d3d2, real(dp), (:,:), size(recv), (:,:,:), 3, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr1(d4d3, real(dp), (:,:,:), size(recv), (:,:,:,:), + 4, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr1(d5d4, real(dp), (:,:,:,:), size(recv), + (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_scatter_dr1(d6d5, real(dp), (:,:,:,:,:), size(recv), + (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) + + + _subroutine_mpifx_scatter_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, + MPI_COMPLEX) + + _subroutine_mpifx_scatter_dr1(c1c0, complex(sp), , 1, (:), 1, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr1(c2c1, complex(sp), (:), size(recv), (:,:), 2, + MPI_COMPLEX) + _subroutine_mpifx_scatter_dr1(c3c2, complex(sp), (:,:), size(recv), (:,:,:), + 3, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr1(c4c3, complex(sp), (:,:,:), size(recv), + (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr1(c5c4, complex(sp), (:,:,:,:), size(recv), + (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_scatter_dr1(c6c5, complex(sp), (:,:,:,:,:), size(recv), + (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + _subroutine_mpifx_scatter_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr0(z3z3, complex(dp), (:,:,:), 3, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr0(z4z4, complex(dp), (:,:,:,:), 4, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_scatter_dr1(z1z0, complex(dp), , 1, (:), 1, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr1(z2z1, complex(dp), (:), size(recv), (:,:), 2, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr1(z3z2, complex(dp), (:,:), size(recv), (:,:,:), + 3, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr1(z4z3, complex(dp), (:,:,:), size(recv), + (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr1(z5z4, complex(dp), (:,:,:,:), size(recv), + (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_scatter_dr1(z6z5, complex(dp), (:,:,:,:,:), size(recv), + (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) + + + _subroutine_mpifx_scatter_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + _subroutine_mpifx_scatter_dr1(l1l0, logical, , 1, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr1(l2l1, logical, (:), size(recv), (:,:), 2, + MPI_LOGICAL) + _subroutine_mpifx_scatter_dr1(l3l2, logical, (:,:), size(recv), (:,:,:), 3, + MPI_LOGICAL) + _subroutine_mpifx_scatter_dr1(l4l3, logical, (:,:,:), size(recv), (:,:,:,:), + 4, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr1(l5l4, logical, (:,:,:,:), size(recv), + (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_scatter_dr1(l6l5, logical, (:,:,:,:,:), size(recv), + (:,:,:,:,:,:), 6, MPI_LOGICAL) + + +end module mpifx_scatter_module diff --git a/src/mpifx_scatter.m4 b/src/mpifx_scatter.m4 new file mode 100644 index 0000000..9242fac --- /dev/null +++ b/src/mpifx_scatter.m4 @@ -0,0 +1,82 @@ +include(mpifx_common.m4) + +dnl ************************************************************************ +dnl *** mpifx_scatter +dnl ************************************************************************ + +define(`_subroutine_mpifx_scatter_dr0',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send/recv buffer rank (1, 2, etc.) +dnl $5: corresponding MPI type +dnl +!> Scatters object from one process (type $1). +!! +!! \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%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_scatter_$1(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$3 + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + _assert(.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) + _assert(.not. mycomm%master .or. & + & size(send, dim=$4) == size(recv, dim=$4) * mycomm%size) + + _handle_inoptflag(root0, root, mycomm%masterrank) + call mpi_scatter(send, size(recv), $5, recv, size(recv), & + & $5, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatter_$1", error) + +end subroutine mpifx_scatter_$1 +') + + +define(`_subroutine_mpifx_scatter_dr1',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: recv buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: recv buffer size (1 or size(recv)) +dnl $5: send buffer rank specifier ((:), (:,:), etc.) +dnl $6: send buffer rank (1, 2, etc.) +dnl $7: corresponding MPI type +dnl +!> Scatters results on one process (type $1). +!! +!! \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%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_scatter_$1(mycomm, send, recv, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$5 + $2, intent(out) :: recv$3 + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + + _assert(.not. mycomm%master .or. size(send) == $4 * mycomm%size) + _assert(.not. mycomm%master .or. size(send, dim=$6) == mycomm%size) + + _handle_inoptflag(root0, root, mycomm%masterrank) + call mpi_scatter(send, $4, $7, recv, $4, & + & $7, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatter_$1", error) + +end subroutine mpifx_scatter_$1 + +') diff --git a/src/mpifx_send.m4 b/src/mpifx_send.m4 index 758b142..5f60be7 100644 --- a/src/mpifx_send.m4 +++ b/src/mpifx_send.m4 @@ -1,4 +1,4 @@ -include(common.m4) +include(mpifx_common.m4) dnl ************************************************************************ dnl *** mpifx_send diff --git a/test/GNUmakefile b/test/GNUmakefile index a857406..4cd3872 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -23,7 +23,8 @@ include ../make.arch .SUFFIXES: .SUFFIXES: .f90 .F90 .o .m4 -BINARIES = test_bcast test_send_recv test_comm_split test_reduce +BINARIES = test_bcast test_send_recv test_comm_split test_reduce \ + test_allreduce test_gather test_allgather test_scatter all: $(BINARIES) 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_allreduce.f90 b/test/test_allreduce.f90 new file mode 100644 index 0000000..e787d10 --- /dev/null +++ b/test/test_allreduce.f90 @@ -0,0 +1,29 @@ +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() + + 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 + 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 diff --git a/test/test_gather.f90 b/test/test_gather.f90 new file mode 100644 index 0000000..bbd0630 --- /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%master) 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%master) 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%master) 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%master) 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%master) 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%master) 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_scatter.f90 b/test/test_scatter.f90 new file mode 100644 index 0000000..8bcf63f --- /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%master) 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%master) 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%master) 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 From 338548aa3f9832b3c1b722701bbebdad076a2c5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Sat, 24 Aug 2013 18:05:11 +0200 Subject: [PATCH 04/72] Documentation (user manual) added. --- README.rst | 21 ++-- doc/sphinx/Makefile | 153 +++++++++++++++++++++++ doc/sphinx/about.rst | 41 +++++++ doc/sphinx/conf.py | 249 ++++++++++++++++++++++++++++++++++++++ doc/sphinx/index.rst | 12 ++ doc/sphinx/installing.rst | 83 +++++++++++++ doc/sphinx/license.rst | 29 +++++ doc/sphinx/routines.rst | 9 ++ doc/sphinx/using.rst | 73 +++++++++++ src/libmpifx.F90 | 18 ++- 10 files changed, 680 insertions(+), 8 deletions(-) create mode 100644 doc/sphinx/Makefile create mode 100644 doc/sphinx/about.rst create mode 100644 doc/sphinx/conf.py create mode 100644 doc/sphinx/index.rst create mode 100644 doc/sphinx/installing.rst create mode 100644 doc/sphinx/license.rst create mode 100644 doc/sphinx/routines.rst create mode 100644 doc/sphinx/using.rst diff --git a/README.rst b/README.rst index f3c1704..61aaace 100644 --- a/README.rst +++ b/README.rst @@ -1,12 +1,19 @@ 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 `_ is +an effort to provide modern Fortran (Fortran 2003) wrappers around +routines of the MPI library to make their use as simple as possible. -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**). +A few essential communication routines are already covered. See the +documentation or the `online API DOCUMENTATION +`_ whether the routines +you need are there. If not, 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**. -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. +Information about installation and usage of the library you find in the +documentation in the source or in the `online documentation +`_. Project status, current source code, +bugtracker etc. can be found on the `MPIFX project home page +`_. 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/about.rst b/doc/sphinx/about.rst new file mode 100644 index 0000000..0c9b889 --- /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 master 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 +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..91558a8 --- /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 = 'sphinxdoc' + +# 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..2291daa --- /dev/null +++ b/doc/sphinx/installing.rst @@ -0,0 +1,83 @@ +Compiling and installing MPIFX +============================== + +In order to compile MPIFX, you need following prerequisites: + +* Fortran 2003 compiler, + +* GNU M4 macro interpreter, + +* GNU Make. + +There are basically two different ways of invoking the library into your +project: + +* `Precompiling the library`_ and linking it later to your project. + +* `Compiling the library during your build process`_. + +Both are described below in details. + + +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. + +#. Change to the `src/` folder. + +#. Issue `make` to build the library. + +#. Copy *all* module files (usually ending on `.mod` and the library + `libmpifx.a` to a place, where your Fortran compiler and your linker can + recognize them. + +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 `src/` folder into a *separate* folder within your + project. + +#. During the make process of your project, invoke the library makefile + (`Makefile.lib`) to build the module files and the library in the build + directory of your project. 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)`, `$(M4)` and `$(M4OPT)` contain + the Fortran compiler, the Fortran compiler options, the linker, the linker + options, the M4 preprocessor and its options, respectively, you would have + something like:: + + libmpifx.a: + $(MAKE) \ + FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ + LN="$(LN)" LNOPT="$(LNOPT)" \ + M4="$(M4)" M4OPT="-I $(SRCDIR) $(M4OPT)" \ + VPATH="$(SRCDIR)" \ + -f "$(SRCDIR)/Makefile.lib" + + in the makefile of your project with `$(SCRDIR)` being the directory where + you put the source of MPIFX. + +You should also have a look at the `GNUmakefile` in the `test/` folder of MPIFX, +which uses exactly the same technique to compile the library during the build +process for the tests. diff --git a/doc/sphinx/license.rst b/doc/sphinx/license.rst new file mode 100644 index 0000000..aa7600f --- /dev/null +++ b/doc/sphinx/license.rst @@ -0,0 +1,29 @@ +License +======= + +MPIFX is licensed under the simplified BSD license:: + + Copyright (c) 2013, 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..62a0b2f --- /dev/null +++ b/doc/sphinx/routines.rst @@ -0,0 +1,9 @@ +.. _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) or watch them in the `Online API +documentation `_. Look +for the detailed descriptions of the interfaces for examples. diff --git a/doc/sphinx/using.rst b/doc/sphinx/using.rst new file mode 100644 index 0000000..c11f6d2 --- /dev/null +++ b/doc/sphinx/using.rst @@ -0,0 +1,73 @@ +Using MPIFX +=========== + +Before you can use the MPIFX routines, you need basically 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 can 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/src/libmpifx.F90 b/src/libmpifx.F90 index f9e02c3..4c99116 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -1,5 +1,21 @@ -!> \mainpage Fortran 2003 wrappers around MPI routines +!> \mainpage Modern Fortran wrappers around MPI routines +!! +!! The open source library [MPIFX](https://www.bitbucket.org/aradi/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. !! +!! A few essential communication routines are already covered. See the +!! * [API DOCUMENTATION](annotated.html) +!! +!! whether the routines you need are there. If not, 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**. +!! +!! Information about installation and usage of the library you find in the +!! [Wiki](https://www.bitbucket.org/aradi/mpifx/wiki). +!! Project status, current source code, bugtracker etc. are to be found on the +!! [MPIFX project home page](https://www.bitbucket.org/aradi/mpifx). +!! module libmpifx_module use mpifx_constants_module use mpifx_comm_module From b7bf22d99dcbd77cbf831755311572a98f7d5e8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Sat, 24 Aug 2013 18:08:56 +0200 Subject: [PATCH 05/72] Minor fix in README. --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index 61aaace..a118c0b 100644 --- a/README.rst +++ b/README.rst @@ -6,7 +6,7 @@ an effort to provide modern Fortran (Fortran 2003) wrappers around routines of the MPI library to make their use as simple as possible. A few essential communication routines are already covered. See the -documentation or the `online API DOCUMENTATION +documentation or the `online API documentation `_ whether the routines you need are there. If not, you are cordially invited to extend MPIFX and to share it in order to let others profit from your work. MPIFX is licensed under From 712c922c1bfff620971bf4fc1fe0aede8318b2cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 2 Sep 2013 17:00:00 +0200 Subject: [PATCH 06/72] Adding automatically determined dependencies. --- doc/sphinx/installing.rst | 28 +++++----- src/GNUmakefile | 12 ++-- src/Makefile.dep | 112 ++++++++++++++++++++++++++++++++++++++ src/Makefile.lib | 42 +++----------- test/GNUmakefile | 52 ++++++++++-------- test/Makefile.dep | 26 +++++++++ test/Makefile.targets | 23 ++++++++ 7 files changed, 217 insertions(+), 78 deletions(-) create mode 100644 src/Makefile.dep create mode 100644 test/Makefile.dep create mode 100644 test/Makefile.targets diff --git a/doc/sphinx/installing.rst b/doc/sphinx/installing.rst index 2291daa..6abe4c7 100644 --- a/doc/sphinx/installing.rst +++ b/doc/sphinx/installing.rst @@ -43,7 +43,7 @@ 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:: + F2003_COMPILER -I -c somesource.f90 and link your object files at the end with:: @@ -59,24 +59,24 @@ In order to build the library during the build process of your project: project. #. During the make process of your project, invoke the library makefile - (`Makefile.lib`) to build the module files and the library in the build - directory of your project. 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)`, `$(M4)` and `$(M4OPT)` contain - the Fortran compiler, the Fortran compiler options, the linker, the linker - options, the M4 preprocessor and its options, respectively, you would have - something like:: + (`Makefile.lib`) 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)`, `$(M4)` and `$(M4OPT)` contain the Fortran compiler, the + Fortran compiler options, the linker, the linker options, the M4 preprocessor + and its options, respectively, you would have something like:: libmpifx.a: - $(MAKE) \ + $(MAKE) -C $(MPIFX_SRCDIR) \ FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="-I $(SRCDIR) $(M4OPT)" \ - VPATH="$(SRCDIR)" \ - -f "$(SRCDIR)/Makefile.lib" + M4="$(M4)" M4OPT="$(M4OPT)" \ + -f Makefile.lib - in the makefile of your project with `$(SCRDIR)` being the directory where - you put the source of MPIFX. + in the makefile of your project with `$(MPIFX_SRCDIR)` being the directory + where you've put the source of MPIFX. You should also have a look at the `GNUmakefile` in the `test/` folder of MPIFX, which uses exactly the same technique to compile the library during the build diff --git a/src/GNUmakefile b/src/GNUmakefile index 4ebc54f..4affd8c 100644 --- a/src/GNUmakefile +++ b/src/GNUmakefile @@ -8,16 +8,14 @@ include ../make.arch -libmpifx.a: +.PHONY: _FORCED_SUBMAKE_ +_FORCED_SUBMAKE_: $(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 +.PHONY: clean distclean +clean distclean: + $(MAKE) -f Makefile.lib $@ diff --git a/src/Makefile.dep b/src/Makefile.dep new file mode 100644 index 0000000..58bab14 --- /dev/null +++ b/src/Makefile.dep @@ -0,0 +1,112 @@ +.SECONDEXPANSION: + +mpifx_barrier.o: mpifx_barrier.m4 $$(_modobj_mpifx_common_module) +mpifx_barrier.o = mpifx_barrier.o $(mpifx_barrier.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_barrier_module = mpifx_barrier.o + +mpifx_init.m4: mpifx_common.m4 +mpifx_init.m4 = $(mpifx_common.m4) + +mpifx_abort.o: mpifx_abort.m4 $$(_modobj_mpifx_common_module) +mpifx_abort.o = mpifx_abort.o $(mpifx_abort.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_abort_module = mpifx_abort.o + +mpifx_constants.o: mpifx_constants.m4 $$(_modobj_mpi) +mpifx_constants.o = mpifx_constants.o $(mpifx_constants.m4) $($(_modobj_mpi)) +_modobj_mpifx_constants_module = mpifx_constants.o + +mpifx_allreduce.o: mpifx_allreduce.m4 $$(_modobj_mpifx_common_module) +mpifx_allreduce.o = mpifx_allreduce.o $(mpifx_allreduce.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_allreduce_module = mpifx_allreduce.o + +mpifx_send.o: mpifx_send.m4 $$(_modobj_mpifx_common_module) +mpifx_send.o = mpifx_send.o $(mpifx_send.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_send_module = mpifx_send.o + +mpifx_reduce.m4: mpifx_common.m4 +mpifx_reduce.m4 = $(mpifx_common.m4) + +mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 +mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) $(mpifx_gather.m4) +_modobj_mpifx_gather_module = mpifx_gather.o + +mpifx_comm.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_comm.m4 +mpifx_comm.o = mpifx_comm.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_comm.m4) +_modobj_mpifx_comm_module = mpifx_comm.o + +mpifx_scatter.o: $$(_modobj_mpifx_common_module) mpifx_scatter.m4 +mpifx_scatter.o = mpifx_scatter.o $($(_modobj_mpifx_common_module)) $(mpifx_scatter.m4) +_modobj_mpifx_scatter_module = mpifx_scatter.o + +mpifx_scatter.m4: mpifx_common.m4 +mpifx_scatter.m4 = $(mpifx_common.m4) + +mpifx_finalize.o: mpifx_finalize.m4 $$(_modobj_mpifx_common_module) +mpifx_finalize.o = mpifx_finalize.o $(mpifx_finalize.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_finalize_module = mpifx_finalize.o + +mpifx_barrier.m4: mpifx_common.m4 +mpifx_barrier.m4 = $(mpifx_common.m4) + +mpifx_recv.m4: mpifx_common.m4 +mpifx_recv.m4 = $(mpifx_common.m4) + +mpifx_helper.o: mpifx_helper.m4 $$(_modobj_mpi) +mpifx_helper.o = mpifx_helper.o $(mpifx_helper.m4) $($(_modobj_mpi)) +_modobj_mpifx_helper_module = mpifx_helper.o + +mpifx_gather.m4: mpifx_common.m4 +mpifx_gather.m4 = $(mpifx_common.m4) + +mpifx_finalize.m4: mpifx_common.m4 +mpifx_finalize.m4 = $(mpifx_common.m4) + +mpifx_allgather.o: mpifx_allgather.m4 $$(_modobj_mpifx_common_module) +mpifx_allgather.o = mpifx_allgather.o $(mpifx_allgather.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_allgather_module = mpifx_allgather.o + +mpifx_init.o: mpifx_init.m4 $$(_modobj_mpifx_common_module) +mpifx_init.o = mpifx_init.o $(mpifx_init.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_init_module = mpifx_init.o + +mpifx_abort.m4: mpifx_common.m4 +mpifx_abort.m4 = $(mpifx_common.m4) + +mpifx_bcast.o: $$(_modobj_mpifx_common_module) mpifx_bcast.m4 +mpifx_bcast.o = mpifx_bcast.o $($(_modobj_mpifx_common_module)) $(mpifx_bcast.m4) +_modobj_mpifx_bcast_module = mpifx_bcast.o + +mpifx_send.m4: mpifx_common.m4 +mpifx_send.m4 = $(mpifx_common.m4) + +mpifx_common.o: $$(_modobj_mpi) mpifx_common.m4 $$(_modobj_mpifx_comm_module) $$(_modobj_mpifx_helper_module) +mpifx_common.o = mpifx_common.o $($(_modobj_mpi)) $(mpifx_common.m4) $($(_modobj_mpifx_comm_module)) $($(_modobj_mpifx_helper_module)) +_modobj_mpifx_common_module = mpifx_common.o + +mpifx_common.m4: mpifx_helper.m4 +mpifx_common.m4 = $(mpifx_helper.m4) + +mpifx_bcast.m4: mpifx_common.m4 +mpifx_bcast.m4 = $(mpifx_common.m4) + +libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +_modobj_libmpifx_module = libmpifx.o + +mpifx_allreduce.m4: mpifx_common.m4 +mpifx_allreduce.m4 = $(mpifx_common.m4) + +mpifx_reduce.o: mpifx_reduce.m4 $$(_modobj_mpifx_common_module) +mpifx_reduce.o = mpifx_reduce.o $(mpifx_reduce.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_reduce_module = mpifx_reduce.o + +mpifx_recv.o: $$(_modobj_mpifx_common_module) mpifx_recv.m4 +mpifx_recv.o = mpifx_recv.o $($(_modobj_mpifx_common_module)) $(mpifx_recv.m4) +_modobj_mpifx_recv_module = mpifx_recv.o + +mpifx_comm.m4: mpifx_helper.m4 +mpifx_comm.m4 = $(mpifx_helper.m4) + +mpifx_allgather.m4: mpifx_common.m4 +mpifx_allgather.m4 = $(mpifx_common.m4) + diff --git a/src/Makefile.lib b/src/Makefile.lib index 1a57969..ad1478b 100644 --- a/src/Makefile.lib +++ b/src/Makefile.lib @@ -9,21 +9,20 @@ # 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. You may also use the -D option to define macros (e.g. DEBUG) -# VPATH: The path to this directory, if you invoke the makefile from -# somewhere else. # ############################################################################### .SUFFIXES: .SUFFIXES: .f90 .F90 .o -FILENAMES = libmpifx mpifx_helper mpifx_comm mpifx_common mpifx_barrier \ - mpifx_bcast mpifx_send mpifx_recv mpifx_abort mpifx_init mpifx_finalize \ - mpifx_reduce mpifx_allreduce mpifx_constants mpifx_gather mpifx_allgather \ - mpifx_scatter TARGETLIB = libmpifx.a -$(TARGETLIB): $(patsubst %,%.o,$(FILENAMES)) +.PHONY: all +all: $(TARGETLIB) + +include Makefile.dep + +$(TARGETLIB): $(libmpifx.o) ar r $@ $^ %.f90: %.F90 @@ -35,36 +34,13 @@ $(TARGETLIB): $(patsubst %,%.o,$(FILENAMES)) .PHONY: clean realclean clean: - rm -f $(patsubst %,%.o,$(FILENAMES)) - rm -f $(patsubst %,%.f90,$(FILENAMES)) + rm -f *.o -realclean: clean - rm -f $(patsubst %,%_module.mod,$(FILENAMES)) +distclean: clean + rm -f *.mod rm -f $(TARGETLIB) -# Explicit dependencies -libmpifx.o: mpifx_comm.o mpifx_abort.o mpifx_barrier.o \ - mpifx_bcast.o mpifx_finalize.o mpifx_init.o mpifx_send.o mpifx_recv.o \ - mpifx_reduce.o mpifx_allreduce.o mpifx_constants.o mpifx_gather.o \ - mpifx_allgather.o mpifx_scatter.o -mpifx_abort.o: mpifx_common.o -mpifx_barrier.o: mpifx_common.o -mpifx_bcast.o: mpifx_common.o -mpifx_comm.o: mpifx_helper.o -mpifx_common.o: mpifx_helper.o mpifx_comm.o -mpifx_constants.o: -mpifx_finalize.o: mpifx_common.o -mpifx_helper.o: -mpifx_init.o: mpifx_common.o -mpifx_reduce.o: mpifx_common.o -mpifx_allreduce.o: mpifx_common.o -mpifx_send.o: mpifx_common.o -mpifx_recv.o: mpifx_common.o -mpifx_gather.o: mpifx_common.o -mpifx_allgather.o: mpifx_common.o -mpifx_scatter.o: mpifx_common.o - ### Local Variables: ### mode:makefile ### End: diff --git a/test/GNUmakefile b/test/GNUmakefile index 4cd3872..70e8b92 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -7,11 +7,10 @@ # ############################################################################ -# Directory where library source can be found -SRCDIR = ../src - include ../make.arch +# Directory where library source can be found +SRCDIR = ../src ############################################################################ # Building the test programs. @@ -23,41 +22,46 @@ include ../make.arch .SUFFIXES: .SUFFIXES: .f90 .F90 .o .m4 -BINARIES = test_bcast test_send_recv test_comm_split test_reduce \ +TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ test_allreduce test_gather test_allgather test_scatter -all: $(BINARIES) +all: $(TARGETS) -# General rule for executables (without suffix) -%: %.o - $(LN) $(LNOPT) -o $@ $^ -L./ -lmpifx +# Create dependencies (make sure every targets .o file additionally depends on +# the external libary, as the library modfiles must been created first) +include Makefile.dep +$(TARGETS:=.o): _extlib_mpifx +# Include linking rules for targets +define link-target +$(LN) $(LNOPT) -o $@ $(filter-out _%,$^) -L$(SRCDIR) -lmpifx +endef +include Makefile.targets %.o: %.f90 - $(FXX) $(FXXOPT) -c $< + $(FXX) $(FXXOPT) -I$(SRCDIR) -c $< .PHONY: clean realclean clean: - $(MAKE) -f $(SRCDIR)/Makefile.lib clean - rm -f *.mod *.o + $(MAKE) -C $(SRCDIR) -f Makefile.lib clean + rm -f *.mod *.o _* -realclean: clean - $(MAKE) -f $(SRCDIR)/Makefile.lib realclean - rm -f $(BINARIES) +distclean: clean + $(MAKE) -C $(SRCDIR) -f Makefile.lib distclean + rm -f $(TARGETS) -# Dependencies: test programs can only be compiled after library is done as -# the compiler needs the .mod files -$(BINARIES): libmpifx.a +############################################################################ +# Invoking the makefile of the library to build it in its directory +############################e################################################ +.PHONY: _FORCED_SUBMAKE_ +_extlib_mpifx: _FORCED_SUBMAKE_ + touch -r $(SRCDIR)/libmpifx.a $@ -############################################################################ -# Invoking the makefile of the library to build it in place. -############################################################################ -libmpifx.a: +_FORCED_SUBMAKE_: $(MAKE) \ FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="-I $(SRCDIR) $(M4OPT)" \ - VPATH="$(SRCDIR)" \ - -f "$(SRCDIR)/Makefile.lib" + M4="$(M4)" M4OPT="$(M4OPT)" \ + -C $(SRCDIR) -f Makefile.lib diff --git a/test/Makefile.dep b/test/Makefile.dep new file mode 100644 index 0000000..7c7be27 --- /dev/null +++ b/test/Makefile.dep @@ -0,0 +1,26 @@ +.SECONDEXPANSION: + +test_allgather.o: $$(_modobj_libmpifx_module) +test_allgather.o = test_allgather.o $($(_modobj_libmpifx_module)) + +test_gather.o: $$(_modobj_libmpifx_module) +test_gather.o = test_gather.o $($(_modobj_libmpifx_module)) + +test_send_recv.o: $$(_modobj_libmpifx_module) +test_send_recv.o = test_send_recv.o $($(_modobj_libmpifx_module)) + +test_bcast.o: $$(_modobj_libmpifx_module) +test_bcast.o = test_bcast.o $($(_modobj_libmpifx_module)) + +test_scatter.o: $$(_modobj_libmpifx_module) +test_scatter.o = test_scatter.o $($(_modobj_libmpifx_module)) + +test_comm_split.o: $$(_modobj_libmpifx_module) +test_comm_split.o = test_comm_split.o $($(_modobj_libmpifx_module)) + +test_reduce.o: $$(_modobj_libmpifx_module) +test_reduce.o = test_reduce.o $($(_modobj_libmpifx_module)) + +test_allreduce.o: $$(_modobj_libmpifx_module) +test_allreduce.o = test_allreduce.o $($(_modobj_libmpifx_module)) + diff --git a/test/Makefile.targets b/test/Makefile.targets new file mode 100644 index 0000000..b09ddf5 --- /dev/null +++ b/test/Makefile.targets @@ -0,0 +1,23 @@ +test_bcast: $(test_bcast.o) + $(link-target) + +test_send_recv: $(test_send_recv.o) + $(link-target) + +test_comm_split: $(test_comm_split.o) + $(link-target) + +test_reduce: $(test_reduce.o) + $(link-target) + +test_allreduce: $(test_allreduce.o) + $(link-target) + +test_gather: $(test_gather.o) + $(link-target) + +test_allgather: $(test_allgather.o) + $(link-target) + +test_scatter: $(test_scatter.o) + $(link-target) From caa9127199da222e8d22b769fba32084884b16cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 4 Sep 2013 23:54:09 +0200 Subject: [PATCH 07/72] In place verion of reduce and allreduce implemented. --- src/mpifx_allreduce.F90 | 144 +++++++++++++++++++++++++++++++++++++++- src/mpifx_allreduce.m4 | 31 +++++++++ src/mpifx_reduce.F90 | 133 ++++++++++++++++++++++++++++++++++++- src/mpifx_reduce.m4 | 41 ++++++++++++ test/test_allreduce.f90 | 13 ++++ test/test_reduce.f90 | 14 ++++ 6 files changed, 371 insertions(+), 5 deletions(-) diff --git a/src/mpifx_allreduce.F90 b/src/mpifx_allreduce.F90 index d4394de..8e04143 100644 --- a/src/mpifx_allreduce.F90 +++ b/src/mpifx_allreduce.F90 @@ -6,7 +6,7 @@ module mpifx_allreduce_module implicit none private - public :: mpifx_allreduce + public :: mpifx_allreduce, mpifx_allreduceip !> Reduces a scalar/array on all nodes. !! @@ -69,7 +69,70 @@ module mpifx_allreduce_module & mpifx_allreduce_l0, mpifx_allreduce_l1, mpifx_allreduce_l2, & & mpifx_allreduce_l3, mpifx_allreduce_l4, mpifx_allreduce_l5, & & mpifx_allreduce_l6 - end interface + 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 + module procedure & + & mpifx_allreduceip_i0, mpifx_allreduceip_i1, mpifx_allreduceip_i2, & + & mpifx_allreduceip_i3, mpifx_allreduceip_i4, mpifx_allreduceip_i5, & + & mpifx_allreduceip_i6 + module procedure & + & mpifx_allreduceip_s0, mpifx_allreduceip_s1, mpifx_allreduceip_s2, & + & mpifx_allreduceip_s3, mpifx_allreduceip_s4, mpifx_allreduceip_s5, & + & mpifx_allreduceip_s6 + module procedure & + & mpifx_allreduceip_d0, mpifx_allreduceip_d1, mpifx_allreduceip_d2, & + & mpifx_allreduceip_d3, mpifx_allreduceip_d4, mpifx_allreduceip_d5, & + & mpifx_allreduceip_d6 + module procedure & + & mpifx_allreduceip_c0, mpifx_allreduceip_c1, mpifx_allreduceip_c2, & + & mpifx_allreduceip_c3, mpifx_allreduceip_c4, mpifx_allreduceip_c5, & + & mpifx_allreduceip_c6 + module procedure & + & mpifx_allreduceip_z0, mpifx_allreduceip_z1, mpifx_allreduceip_z2, & + & mpifx_allreduceip_z3, mpifx_allreduceip_z4, mpifx_allreduceip_z5, & + & mpifx_allreduceip_z6 + module procedure & + & mpifx_allreduceip_l0, mpifx_allreduceip_l1, mpifx_allreduceip_l2, & + & mpifx_allreduceip_l3, mpifx_allreduceip_l4, mpifx_allreduceip_l5, & + & mpifx_allreduceip_l6 + end interface mpifx_allreduceip contains @@ -146,5 +209,82 @@ module mpifx_allreduce_module _subroutine_mpifx_allreduce(l6, logical, (:,:,:,:,:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_allreduceip(i0, integer, , 1, MPI_INTEGER) + _subroutine_mpifx_allreduceip(i1, integer, (:), size(opres), MPI_INTEGER) + _subroutine_mpifx_allreduceip(i2, integer, (:,:), size(opres), MPI_INTEGER) + _subroutine_mpifx_allreduceip(i3, integer, (:,:,:), size(opres), + MPI_INTEGER) + _subroutine_mpifx_allreduceip(i4, integer, (:,:,:,:), size(opres), + MPI_INTEGER) + _subroutine_mpifx_allreduceip(i5, integer, (:,:,:,:,:), size(opres), + MPI_INTEGER) + _subroutine_mpifx_allreduceip(i6, integer, (:,:,:,:,:,:), size(opres), + MPI_INTEGER) + + _subroutine_mpifx_allreduceip(s0, real(sp), , 1, MPI_REAL) + _subroutine_mpifx_allreduceip(s1, real(sp), (:), size(opres), MPI_REAL) + _subroutine_mpifx_allreduceip(s2, real(sp), (:,:), size(opres), MPI_REAL) + _subroutine_mpifx_allreduceip(s3, real(sp), (:,:,:), size(opres), MPI_REAL) + _subroutine_mpifx_allreduceip(s4, real(sp), (:,:,:,:), size(opres), + MPI_REAL) + _subroutine_mpifx_allreduceip(s5, real(sp), (:,:,:,:,:), size(opres), + MPI_REAL) + _subroutine_mpifx_allreduceip(s6, real(sp), (:,:,:,:,:,:), size(opres), + MPI_REAL) + + _subroutine_mpifx_allreduceip(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduceip(d1, real(dp), (:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduceip(d2, real(dp), (:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduceip(d3, real(dp), (:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduceip(d4, real(dp), (:,:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduceip(d5, real(dp), (:,:,:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allreduceip(d6, real(dp), (:,:,:,:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_allreduceip(c0, complex(sp), , 1, MPI_COMPLEX) + _subroutine_mpifx_allreduceip(c1, complex(sp), (:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_allreduceip(c2, complex(sp), (:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_allreduceip(c3, complex(sp), (:,:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_allreduceip(c4, complex(sp), (:,:,:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_allreduceip(c5, complex(sp), (:,:,:,:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_allreduceip(c6, complex(sp), (:,:,:,:,:,:), size(opres), + MPI_COMPLEX) + + _subroutine_mpifx_allreduceip(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduceip(z1, complex(dp), (:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduceip(z2, complex(dp), (:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduceip(z3, complex(dp), (:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduceip(z4, complex(dp), (:,:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduceip(z5, complex(dp), (:,:,:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allreduceip(z6, complex(dp), (:,:,:,:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_allreduceip(l0, logical, , 1, MPI_LOGICAL) + _subroutine_mpifx_allreduceip(l1, logical, (:), size(opres), MPI_LOGICAL) + _subroutine_mpifx_allreduceip(l2, logical, (:,:), size(opres), MPI_LOGICAL) + _subroutine_mpifx_allreduceip(l3, logical, (:,:,:), size(opres), + MPI_LOGICAL) + _subroutine_mpifx_allreduceip(l4, logical, (:,:,:,:), size(opres), + MPI_LOGICAL) + _subroutine_mpifx_allreduceip(l5, logical, (:,:,:,:,:), size(opres), + MPI_LOGICAL) + _subroutine_mpifx_allreduceip(l6, logical, (:,:,:,:,:,:), size(opres), + MPI_LOGICAL) + end module mpifx_allreduce_module diff --git a/src/mpifx_allreduce.m4 b/src/mpifx_allreduce.m4 index 1737f31..5d00915 100644 --- a/src/mpifx_allreduce.m4 +++ b/src/mpifx_allreduce.m4 @@ -32,3 +32,34 @@ subroutine mpifx_allreduce_$1(mycomm, operand, result, operator, error) end subroutine mpifx_allreduce_$1 ') + +dnl ************************************************************************ +dnl *** mpifx_allreduceip +dnl ************************************************************************ + +define(`_subroutine_mpifx_allreduceip',`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 +!> Reduces results on one process (type $1). +!! +!! \param mycomm MPI communicator. +!! \param opres Quantity to be reduced on input, result on exit +!! \param operator Reduction operator +!! \param error Error code on exit. +!! +subroutine mpifx_allreduceip_$1(mycomm, opres, operator, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(inout) :: opres$3 + integer, intent(in) :: operator + integer, intent(out), optional :: error + + integer :: error0 + + call mpi_allreduce(MPI_IN_PLACE, opres, $4, $5, operator, mycomm%id, error0) + call handle_errorflag(error0, "MPI_REDUCE in mpifx_allreduceip_$1", error) + +end subroutine mpifx_allreduceip_$1 +') diff --git a/src/mpifx_reduce.F90 b/src/mpifx_reduce.F90 index 2667038..80539b5 100644 --- a/src/mpifx_reduce.F90 +++ b/src/mpifx_reduce.F90 @@ -6,14 +6,14 @@ module mpifx_reduce_module implicit none private - public :: mpifx_reduce + 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) and logical (l). Their rank can vary from + !! 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. !! @@ -57,7 +57,65 @@ module mpifx_reduce_module & mpifx_reduce_z3, mpifx_reduce_z4, mpifx_reduce_z5, mpifx_reduce_z6 module procedure mpifx_reduce_l0, mpifx_reduce_l1, mpifx_reduce_l2, & & mpifx_reduce_l3, mpifx_reduce_l4, mpifx_reduce_l5, mpifx_reduce_l6 - end interface + 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 + module procedure mpifx_reduceip_i0, mpifx_reduceip_i1, mpifx_reduceip_i2, & + & mpifx_reduceip_i3, mpifx_reduceip_i4, mpifx_reduceip_i5, & + & mpifx_reduceip_i6 + module procedure mpifx_reduceip_s0, mpifx_reduceip_s1, mpifx_reduceip_s2, & + & mpifx_reduceip_s3, mpifx_reduceip_s4, mpifx_reduceip_s5, & + & mpifx_reduceip_s6 + module procedure mpifx_reduceip_d0, mpifx_reduceip_d1, mpifx_reduceip_d2, & + & mpifx_reduceip_d3, mpifx_reduceip_d4, mpifx_reduceip_d5, & + & mpifx_reduceip_d6 + module procedure mpifx_reduceip_c0, mpifx_reduceip_c1, mpifx_reduceip_c2, & + & mpifx_reduceip_c3, mpifx_reduceip_c4, mpifx_reduceip_c5, & + & mpifx_reduceip_c6 + module procedure mpifx_reduceip_z0, mpifx_reduceip_z1, mpifx_reduceip_z2, & + & mpifx_reduceip_z3, mpifx_reduceip_z4, mpifx_reduceip_z5, & + & mpifx_reduceip_z6 + module procedure mpifx_reduceip_l0, mpifx_reduceip_l1, mpifx_reduceip_l2, & + & mpifx_reduceip_l3, mpifx_reduceip_l4, mpifx_reduceip_l5, & + & mpifx_reduceip_l6 + end interface mpifx_reduceip + contains @@ -127,5 +185,74 @@ module mpifx_reduce_module _subroutine_mpifx_reduce(l6, logical, (:,:,:,:,:,:), size(operand), MPI_LOGICAL) + _subroutine_mpifx_reduceip(i0, integer, , 1, MPI_INTEGER) + _subroutine_mpifx_reduceip(i1, integer, (:), size(opres), MPI_INTEGER) + _subroutine_mpifx_reduceip(i2, integer, (:,:), size(opres), MPI_INTEGER) + _subroutine_mpifx_reduceip(i3, integer, (:,:,:), size(opres), MPI_INTEGER) + _subroutine_mpifx_reduceip(i4, integer, (:,:,:,:), size(opres), MPI_INTEGER) + _subroutine_mpifx_reduceip(i5, integer, (:,:,:,:,:), size(opres), + MPI_INTEGER) + _subroutine_mpifx_reduceip(i6, integer, (:,:,:,:,:,:), size(opres), + MPI_INTEGER) + + _subroutine_mpifx_reduceip(s0, real(sp), , 1, MPI_REAL) + _subroutine_mpifx_reduceip(s1, real(sp), (:), size(opres), MPI_REAL) + _subroutine_mpifx_reduceip(s2, real(sp), (:,:), size(opres), MPI_REAL) + _subroutine_mpifx_reduceip(s3, real(sp), (:,:,:), size(opres), MPI_REAL) + _subroutine_mpifx_reduceip(s4, real(sp), (:,:,:,:), size(opres), MPI_REAL) + _subroutine_mpifx_reduceip(s5, real(sp), (:,:,:,:,:), size(opres), MPI_REAL) + _subroutine_mpifx_reduceip(s6, real(sp), (:,:,:,:,:,:), size(opres), + MPI_REAL) + + _subroutine_mpifx_reduceip(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduceip(d1, real(dp), (:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduceip(d2, real(dp), (:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduceip(d3, real(dp), (:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduceip(d4, real(dp), (:,:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduceip(d5, real(dp), (:,:,:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_reduceip(d6, real(dp), (:,:,:,:,:,:), size(opres), + MPI_DOUBLE_PRECISION) + + _subroutine_mpifx_reduceip(c0, complex(sp), , 1, MPI_COMPLEX) + _subroutine_mpifx_reduceip(c1, complex(sp), (:), size(opres), MPI_COMPLEX) + _subroutine_mpifx_reduceip(c2, complex(sp), (:,:), size(opres), MPI_COMPLEX) + _subroutine_mpifx_reduceip(c3, complex(sp), (:,:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_reduceip(c4, complex(sp), (:,:,:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_reduceip(c5, complex(sp), (:,:,:,:,:), size(opres), + MPI_COMPLEX) + _subroutine_mpifx_reduceip(c6, complex(sp), (:,:,:,:,:,:), size(opres), + MPI_COMPLEX) + + _subroutine_mpifx_reduceip(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduceip(z1, complex(dp), (:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduceip(z2, complex(dp), (:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduceip(z3, complex(dp), (:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduceip(z4, complex(dp), (:,:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduceip(z5, complex(dp), (:,:,:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_reduceip(z6, complex(dp), (:,:,:,:,:,:), size(opres), + MPI_DOUBLE_COMPLEX) + + _subroutine_mpifx_reduceip(l0, logical, , 1, MPI_LOGICAL) + _subroutine_mpifx_reduceip(l1, logical, (:), size(opres), MPI_LOGICAL) + _subroutine_mpifx_reduceip(l2, logical, (:,:), size(opres), MPI_LOGICAL) + _subroutine_mpifx_reduceip(l3, logical, (:,:,:), size(opres), MPI_LOGICAL) + _subroutine_mpifx_reduceip(l4, logical, (:,:,:,:), size(opres), MPI_LOGICAL) + _subroutine_mpifx_reduceip(l5, logical, (:,:,:,:,:), size(opres), + MPI_LOGICAL) + _subroutine_mpifx_reduceip(l6, logical, (:,:,:,:,:,:), size(opres), + MPI_LOGICAL) + end module mpifx_reduce_module diff --git a/src/mpifx_reduce.m4 b/src/mpifx_reduce.m4 index ce77a92..a81d0e4 100644 --- a/src/mpifx_reduce.m4 +++ b/src/mpifx_reduce.m4 @@ -35,3 +35,44 @@ subroutine mpifx_reduce_$1(mycomm, operand, result, operator, root, error) end subroutine mpifx_reduce_$1 ') + +dnl ************************************************************************ +dnl *** mpifx_reduceip +dnl ************************************************************************ + +define(`_subroutine_mpifx_reduceip',`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 +!> Reduces results on one process (type $1). +!! +!! \param mycomm MPI communicator. +!! \param opres Quantity to be reduced on input, result on exit +!! \param operator Reduction operator +!! \param root Root process for the result (default: mycomm%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_reduceip_$1(mycomm, opres, operator, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(inout) :: opres$3 + integer, intent(in) :: operator + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0 + $2 :: dummy + + _handle_inoptflag(root0, root, mycomm%masterrank) + if (mycomm%rank == root0) then + call mpi_reduce(MPI_IN_PLACE, opres, $4, $5, operator, root0, mycomm%id, & + & error0) + else + call mpi_reduce(opres, dummy, $4, $5, operator, root0, mycomm%id, & + & error0) + end if + call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_$1", error) + +end subroutine mpifx_reduceip_$1 +') diff --git a/test/test_allreduce.f90 b/test/test_allreduce.f90 index e787d10..cfb9df8 100644 --- a/test/test_allreduce.f90 +++ b/test/test_allreduce.f90 @@ -11,12 +11,15 @@ program test_allreduce 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, & @@ -24,6 +27,16 @@ program test_allreduce 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_reduce.f90 b/test/test_reduce.f90 index cde72fd..b5f515b 100644 --- a/test/test_reduce.f90 +++ b/test/test_reduce.f90 @@ -11,19 +11,33 @@ program test_reduce 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 From e3aea889e8643e6f5150a07fb0fe3036d919398b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Thu, 5 Sep 2013 14:38:04 +0200 Subject: [PATCH 08/72] Minor documentation changes. --- src/libmpifx.F90 | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 index 4c99116..60ef727 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -4,17 +4,12 @@ !! an effort to provide modern Fortran (Fortran 2003) wrappers around !! routines of the MPI library to make their use as simple as possible. !! -!! A few essential communication routines are already covered. See the -!! * [API DOCUMENTATION](annotated.html) -!! -!! whether the routines you need are there. If not, 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**. -!! -!! Information about installation and usage of the library you find in the -!! [Wiki](https://www.bitbucket.org/aradi/mpifx/wiki). -!! Project status, current source code, bugtracker etc. are to be found on the -!! [MPIFX project home page](https://www.bitbucket.org/aradi/mpifx). +!! For more information see the following sources: +!! * [Online documentation](https://aradi.bitbucket.org/mpifx/) +!! for installation and usage of the library +!! * [API documentation](annotated.html) for the reference manual. +!! * [Project home page](https://www.bitbucket.org/aradi/mpifx/) +!! for the source code, bug tracker and further information on the project. !! module libmpifx_module use mpifx_constants_module From 3ddd4769c7bee8ccbfba986d31c8a84cc5bfa61d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 22 Oct 2014 19:22:02 +0200 Subject: [PATCH 09/72] Adding wrapper for mpi_get_processor_name --- src/Makefile.dep | 11 ++++++++-- src/libmpifx.F90 | 1 + src/mpifx_get_processor_name.F90 | 37 ++++++++++++++++++++++++++++++++ src/mpifx_get_processor_name.m4 | 1 + 4 files changed, 48 insertions(+), 2 deletions(-) create mode 100644 src/mpifx_get_processor_name.F90 create mode 100644 src/mpifx_get_processor_name.m4 diff --git a/src/Makefile.dep b/src/Makefile.dep index 58bab14..e3e42e5 100644 --- a/src/Makefile.dep +++ b/src/Makefile.dep @@ -23,6 +23,9 @@ mpifx_send.o: mpifx_send.m4 $$(_modobj_mpifx_common_module) mpifx_send.o = mpifx_send.o $(mpifx_send.m4) $($(_modobj_mpifx_common_module)) _modobj_mpifx_send_module = mpifx_send.o +mpifx_get_processor_name.m4: mpifx_helper.m4 +mpifx_get_processor_name.m4 = $(mpifx_helper.m4) + mpifx_reduce.m4: mpifx_common.m4 mpifx_reduce.m4 = $(mpifx_common.m4) @@ -61,6 +64,10 @@ mpifx_gather.m4 = $(mpifx_common.m4) mpifx_finalize.m4: mpifx_common.m4 mpifx_finalize.m4 = $(mpifx_common.m4) +mpifx_get_processor_name.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_get_processor_name.m4 +mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_get_processor_name.m4) +_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o + mpifx_allgather.o: mpifx_allgather.m4 $$(_modobj_mpifx_common_module) mpifx_allgather.o = mpifx_allgather.o $(mpifx_allgather.m4) $($(_modobj_mpifx_common_module)) _modobj_mpifx_allgather_module = mpifx_allgather.o @@ -89,8 +96,8 @@ mpifx_common.m4 = $(mpifx_helper.m4) mpifx_bcast.m4: mpifx_common.m4 mpifx_bcast.m4 = $(mpifx_common.m4) -libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) _modobj_libmpifx_module = libmpifx.o mpifx_allreduce.m4: mpifx_common.m4 diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 index 60ef727..c5e0a4c 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -15,6 +15,7 @@ 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 diff --git a/src/mpifx_get_processor_name.F90 b/src/mpifx_get_processor_name.F90 new file mode 100644 index 0000000..9e0e737 --- /dev/null +++ b/src/mpifx_get_processor_name.F90 @@ -0,0 +1,37 @@ +include(mpifx_get_processor_name.m4) + +!> 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/src/mpifx_get_processor_name.m4 b/src/mpifx_get_processor_name.m4 new file mode 100644 index 0000000..3b8c873 --- /dev/null +++ b/src/mpifx_get_processor_name.m4 @@ -0,0 +1 @@ +include(mpifx_helper.m4) From 1a043038e44b1cc3b7b80b3e89e177223902d559 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Thu, 23 Oct 2014 14:26:18 +0200 Subject: [PATCH 10/72] Documentation changes. --- doc/sphinx/_themes/dftbplus/layout.html | 14 + .../_themes/dftbplus/static/contents.png | Bin 0 -> 202 bytes .../_themes/dftbplus/static/dftbplus.css | 322 ++++++++++++++++ .../_themes/dftbplus/static/navigation.png | Bin 0 -> 218 bytes .../_themes/dftbplus/static/sphinxdoc.css_t | 356 ++++++++++++++++++ doc/sphinx/_themes/dftbplus/theme.conf | 4 + doc/sphinx/about.rst | 8 +- doc/sphinx/conf.py | 4 +- doc/sphinx/routines.rst | 5 +- 9 files changed, 705 insertions(+), 8 deletions(-) create mode 100644 doc/sphinx/_themes/dftbplus/layout.html create mode 100644 doc/sphinx/_themes/dftbplus/static/contents.png create mode 100644 doc/sphinx/_themes/dftbplus/static/dftbplus.css create mode 100644 doc/sphinx/_themes/dftbplus/static/navigation.png create mode 100644 doc/sphinx/_themes/dftbplus/static/sphinxdoc.css_t create mode 100644 doc/sphinx/_themes/dftbplus/theme.conf 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 0000000000000000000000000000000000000000..7fb82154a1748d507925865d3fbf7508d62483e5 GIT binary patch literal 202 zcmeAS@N?(olHy`uVBq!ia0vp^j6kfx!3HGlw@oMq2^0spJ29*~C-V}>;VkfoEM{Qf z76xHPhFNnYfP(BLp1!W^HyC+E#mt?nx10eANtU=qlsM<-=BDPAFgO>bCYGe8D3oWG zWGJ|M`UZqI@`(c#nR~i8hHzY8+H1+jpulh_>fir3VfEN66+LU}oXkrghqJ&VvY3H^ zTNs2H8D`Cq01C2~c>21s-(chw7$R|bZ|_0D0|q>YSbqDzW^|HYIk%*-&O)*`_ 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. +`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:: @@ -38,4 +38,4 @@ 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 `_. +details see the `project page `_. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 91558a8..cb0fdd9 100644 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -89,7 +89,7 @@ # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. -html_theme = 'sphinxdoc' +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 @@ -100,7 +100,7 @@ } # Add any paths that contain custom themes here, relative to this directory. -# html_theme_path = [ "_themes" ] +html_theme_path = [ "_themes" ] # The name for this set of Sphinx documents. If None, it defaults to # " v documentation". diff --git a/doc/sphinx/routines.rst b/doc/sphinx/routines.rst index 62a0b2f..9d87f31 100644 --- a/doc/sphinx/routines.rst +++ b/doc/sphinx/routines.rst @@ -5,5 +5,6 @@ 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) or watch them in the `Online API -documentation `_. Look -for the detailed descriptions of the interfaces for examples. +documentation +`_. Look for +the detailed descriptions of the interfaces for examples. From e77696ce393a27d9b4e845fb8385f313f90d05a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 14 Dec 2016 13:06:53 +0100 Subject: [PATCH 11/72] Change to Fypp preprocessing --- external/fypp/fypp | 2407 +++++++++++++++++ make.arch.template | 8 +- src/GNUmakefile | 4 +- src/Makefile.dep | 145 +- src/Makefile.lib | 12 +- src/{libmpifx.F90 => module.fpp} | 6 +- src/mpifx.fypp | 72 + src/{mpifx_abort.F90 => mpifx_abort.fpp} | 14 +- src/mpifx_abort.m4 | 1 - src/mpifx_allgather.F90 | 248 -- src/mpifx_allgather.fpp | 191 ++ src/mpifx_allgather.m4 | 75 - src/mpifx_allreduce.F90 | 290 -- src/mpifx_allreduce.fpp | 194 ++ src/mpifx_allreduce.m4 | 65 - src/{mpifx_barrier.F90 => mpifx_barrier.fpp} | 2 +- src/mpifx_barrier.m4 | 1 - src/mpifx_bcast.F90 | 133 - src/mpifx_bcast.fpp | 97 + src/mpifx_bcast.m4 | 33 - src/{mpifx_comm.F90 => mpifx_comm.fpp} | 10 +- src/mpifx_comm.m4 | 1 - src/{mpifx_common.F90 => mpifx_common.fpp} | 4 +- src/mpifx_common.m4 | 1 - ...pifx_constants.F90 => mpifx_constants.fpp} | 4 +- src/mpifx_constants.m4 | 0 ...{mpifx_finalize.F90 => mpifx_finalize.fpp} | 5 +- src/mpifx_finalize.m4 | 1 - src/mpifx_gather.F90 | 259 -- src/mpifx_gather.fpp | 202 ++ src/mpifx_gather.m4 | 82 - ..._name.F90 => mpifx_get_processor_name.fpp} | 8 +- src/mpifx_get_processor_name.m4 | 1 - src/mpifx_helper.F90 | 74 - src/mpifx_helper.fpp | 152 ++ src/mpifx_helper.m4 | 46 - src/{mpifx_init.F90 => mpifx_init.fpp} | 2 - src/mpifx_init.m4 | 1 - src/mpifx_recv.F90 | 145 - src/mpifx_recv.fpp | 110 + src/mpifx_recv.m4 | 39 - src/mpifx_reduce.F90 | 258 -- src/mpifx_reduce.fpp | 192 ++ src/mpifx_reduce.m4 | 78 - src/mpifx_scatter.F90 | 254 -- src/mpifx_scatter.fpp | 189 ++ src/mpifx_scatter.m4 | 82 - src/mpifx_send.F90 | 146 - src/mpifx_send.fpp | 105 + src/mpifx_send.m4 | 34 - test/GNUmakefile | 9 +- utils/cr_makedep | 394 +++ 52 files changed, 4396 insertions(+), 2490 deletions(-) create mode 100755 external/fypp/fypp rename src/{libmpifx.F90 => module.fpp} (81%) create mode 100644 src/mpifx.fypp rename src/{mpifx_abort.F90 => mpifx_abort.fpp} (86%) delete mode 100644 src/mpifx_abort.m4 delete mode 100644 src/mpifx_allgather.F90 create mode 100644 src/mpifx_allgather.fpp delete mode 100644 src/mpifx_allgather.m4 delete mode 100644 src/mpifx_allreduce.F90 create mode 100644 src/mpifx_allreduce.fpp delete mode 100644 src/mpifx_allreduce.m4 rename src/{mpifx_barrier.F90 => mpifx_barrier.fpp} (97%) delete mode 100644 src/mpifx_barrier.m4 delete mode 100644 src/mpifx_bcast.F90 create mode 100644 src/mpifx_bcast.fpp delete mode 100644 src/mpifx_bcast.m4 rename src/{mpifx_comm.F90 => mpifx_comm.fpp} (97%) delete mode 100644 src/mpifx_comm.m4 rename src/{mpifx_common.F90 => mpifx_common.fpp} (84%) delete mode 100644 src/mpifx_common.m4 rename src/{mpifx_constants.F90 => mpifx_constants.fpp} (88%) delete mode 100644 src/mpifx_constants.m4 rename src/{mpifx_finalize.F90 => mpifx_finalize.fpp} (93%) delete mode 100644 src/mpifx_finalize.m4 delete mode 100644 src/mpifx_gather.F90 create mode 100644 src/mpifx_gather.fpp delete mode 100644 src/mpifx_gather.m4 rename src/{mpifx_get_processor_name.F90 => mpifx_get_processor_name.fpp} (81%) delete mode 100644 src/mpifx_get_processor_name.m4 delete mode 100644 src/mpifx_helper.F90 create mode 100644 src/mpifx_helper.fpp delete mode 100644 src/mpifx_helper.m4 rename src/{mpifx_init.F90 => mpifx_init.fpp} (97%) delete mode 100644 src/mpifx_init.m4 delete mode 100644 src/mpifx_recv.F90 create mode 100644 src/mpifx_recv.fpp delete mode 100644 src/mpifx_recv.m4 delete mode 100644 src/mpifx_reduce.F90 create mode 100644 src/mpifx_reduce.fpp delete mode 100644 src/mpifx_reduce.m4 delete mode 100644 src/mpifx_scatter.F90 create mode 100644 src/mpifx_scatter.fpp delete mode 100644 src/mpifx_scatter.m4 delete mode 100644 src/mpifx_send.F90 create mode 100644 src/mpifx_send.fpp delete mode 100644 src/mpifx_send.m4 create mode 100755 utils/cr_makedep diff --git a/external/fypp/fypp b/external/fypp/fypp new file mode 100755 index 0000000..6fd0ad7 --- /dev/null +++ b/external/fypp/fypp @@ -0,0 +1,2407 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- +################################################################################ +# +# fypp -- Python powered Fortran preprocessor +# +# Copyright (c) 2016, 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: +# +# 1. Redistributions of source code must retain the above copyright notice, this +# list of conditions and the following disclaimer. +# +# 2. 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. +# +################################################################################ + +'''The functionality of the Fypp preprocessor is mainly realized by +using following classes: + +* `Parser`_: Reads a source file, does basic syntax checking and generates + events. + +* `Builder`_: Builds a tree representation of the source file by + receiving events. Does additional syntax checking. + +* `Renderer`_: Renders a tree built by the builder. + +* `Evaluator`_: Evaluates Python expressions in a designated environment. It is + used by `Renderer`_ when rendering eval directives. + +* `Processor`_: Connects `Parser`_, `Builder`_, `Renderer`_ and `Evaluator`_ + with each other and returns for a given input the preprocessed output. + +* `Fypp`_: The actual Fypp preprocessor. It initializes and drives + `Processor`_. + +* `FyppOptions`_: Contains customizable settings controling the behaviour of + `Fypp`_. Alternatively, the function `get_option_parser()`_ can be used to + obtain an argument parser, which can create settings based on command line + arguments. + +If processing stops prematurely, an instance of one of the following +subclasses of `FyppError`_ is raised: + +* FyppFatalError: Unexpected error (e.g. bad input, missing files, etc.) + +* FyppStopRequest: Stop was triggered by an explicit request in the input + (by a stop- or an assert-directive). + +Additional to those above an additional class is used for fine tuning: + +* `FortranLineFolder`_: Folds overlong lines by using Fortran continuation + lines. + +''' + +from __future__ import print_function +import sys +import types +import re +import os +import errno +import time +from argparse import ArgumentParser +if sys.version_info[0] >= 3: + import builtins +else: + import __builtin__ as builtins + + +VERSION = '1.3-dev' + +STDIN = '' + +FILEOBJ = '' + +STRING = '' + +ERROR_EXIT_CODE = 1 + +USER_ERROR_EXIT_CODE = 2 + +_LINE_DIRECTIVES_PATTERN = r''' +# comment block +(?P(?:^[ \t]*\#!.*\n)+) +| +# line control directive (with optional continuation lines) +^[ \t]*\#:[ \t]*(?P\w+)[ \t]* +(?P.*?(?:&[ \t]*\n[ \t]*&.*?)*)?[ \t]*\n +| +# line eval directive (with optional continuation lines) +^[ \t]*\$:[ \t]*(?P.*?(?:&[ \t]*\n(?:[ \t]*&)?.*?)*)[ \t]*\n +| +# direct call directive (with optional continuation lines) +^[ \t]*@:[ \t]*(?P\w+)[ \t]* +(?P.*?(?:&[ \t]*\n[ \t]*&.*?)*)?[ \t]*\n +''' + +_INLINE_DIRECTIVES_PATTERN = r''' +# inline control directive +\#\{[ \t]*(?P\w+)[ \t]*(?P.*?)?[ \t]*\}\# +| +# inline eval directive +\$\{[ \t]*(?P.*?)[ \t]*\}\$ +''' + +_INLINE_DIRECTIVES_REGEXP = re.compile( + _INLINE_DIRECTIVES_PATTERN, re.VERBOSE | re.MULTILINE) + +_ALL_DIRECTIVES_REGEXP = re.compile( + _LINE_DIRECTIVES_PATTERN + '|' + _INLINE_DIRECTIVES_PATTERN, + re.VERBOSE | re.MULTILINE) + +_DEF_PARAM_REGEXP = re.compile( + r'^(?P\w+)\(\s*(?P(?:(?:\w+\s*,\s*)*(?:\w+)))?\s*\)$') + +_ENDDEF_PARAM_REGEXP = re.compile(r'^(?P\w+)?$') + +_CALL_PARAM_REGEXP = re.compile(r'^(?P\w+)$') + +_SETVAR_PARAM_REGEXP = re.compile( + r'^(?P(?:[(]\s*)?\w+(?:\s*,\s*\w+)*(?:\s*[)])?)'\ + r'(?:(?:(?:\s*=\s*)|\s+)(?P.*))?$') + +_FOR_PARAM_REGEXP = re.compile( + r'^(?P\w+(\s*,\s*\w+)*)\s+in\s+(?P.+)$') + +_INCLUDE_PARAM_REGEXP = re.compile(r'^(\'|")(?P.*?)\1$') + +_COMMENTLINE_REGEXP = re.compile(r'^[ \t]*!.*$') + +_CONTLINE_REGEXP = re.compile(r'&[ \t]*\n(?:[ \t]*&)?') + +_UNESCAPE_REGEXP1 = re.compile(r'([$#])\\(\\*)([{:])') + +_UNESCAPE_REGEXP2 = re.compile(r'(\})\\(\\*)([$#])') + +_UNESCAPE_REGEXP3 = re.compile(r'(@)\\(\\*)([:@])') + +_RESERVED_PREFIX = '__' + +_RESERVED_NAMES = ('defined', 'setvar', 'getvar', '_LINE_', '_FILE_', + '_TIME_', '_DATE_') + + +class FyppError(Exception): + '''Signalizes error occuring during preprocessing. + + Args: + msg (str): Error message. + fname (str): File name. None (default) if file name is not available. + span (tuple of int): Beginning and end line of the region where error + occured or None if not available. + cause (Exception): Contains the exception, which triggered this + exception or None, if this exception is not masking any underlying + one. (Emulates Python 3 exception chaining in a Python 2 compatible + way.) + + Attributes: + msg (str): Error message. + fname (str or None): File name or None if not available. + span (tuple of int or None): Beginning and end line of the region + where error occured or None if not available. Line numbers start + from zero. For directives, which do not consume end of the line, + start and end lines are identical. + cause (Exception): In case this exception is raised in an except block, + the original exception should be passed here. (Emulates Python 3 + exception chaining in a Python 2 compatible way.) + ''' + + def __init__(self, msg, fname=None, span=None, cause=None): + super(FyppError, self).__init__() + self.msg = msg + self.fname = fname + self.span = span + self.cause = cause + + + def __str__(self): + if self.cause is not None: + cause = str(self.cause) + else: + cause = '' + msg = [self.__class__.__name__, ':'] + if self.fname is not None: + msg.append(" file '" + self.fname + "'") + if self.span is not None: + if self.span[1] > self.span[0] + 1: + msg.append(', lines {}-{}'.format( + self.span[0] + 1, self.span[1])) + else: + msg.append(', line {}'.format(self.span[0] + 1)) + msg.append('\n') + if self.msg: + msg.append(self.msg) + return ''.join(msg) + '\n' + cause + + +class FyppFatalError(FyppError): + '''Signalizes an unexpected error during processing.''' + pass + + +class FyppStopRequest(FyppError): + '''Signalizes an explicitely triggered stop (e.g. via stop directive)''' + pass + + +class Parser: + '''Parses a text and generates events when encountering Fypp constructs. + + Args: + includedirs (list): List of directories, in which include files should + be searched for, when they are not found at the default location. + ''' + + def __init__(self, includedirs=None): + + # Directories to search for include files + if includedirs is None: + self._includedirs = [] + else: + self._includedirs = includedirs + + # Name of current file + self._curfile = None + + # Directory of current file + self._curdir = None + + + def parsefile(self, fobj): + '''Parses file or a file like object. + + Args: + fobj (str or file): Name of a file or a file like object. + ''' + if isinstance(fobj, str): + if fobj == STDIN: + self._includefile(None, sys.stdin, STDIN, os.getcwd()) + else: + inpfp = _open_input_file(fobj) + self._includefile(None, inpfp, fobj, os.path.dirname(fobj)) + inpfp.close() + else: + self._includefile(None, fobj, FILEOBJ, os.getcwd()) + + + def _includefile(self, span, fobj, fname, curdir): + oldfile = self._curfile + olddir = self._curdir + self._curfile = fname + self._curdir = curdir + self.handle_include(span, fname) + self._parse(fobj.read()) + self.handle_endinclude(span, fname) + self._curfile = oldfile + self._curdir = olddir + + + def parse(self, txt): + '''Parses string. + + Args: + txt (str): Text to parse. + ''' + self._curfile = STRING + self._curdir = '' + self.handle_include(None, self._curfile) + self._parse(txt) + self.handle_endinclude(None, self._curfile) + + + def handle_include(self, span, fname): + '''Called when parser starts to process a new file. + + It is a dummy methond and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the include directive + or None if called the first time for the main input. + fname (str): Name of the file. + ''' + self._log_event('include', span, filename=fname) + + + def handle_endinclude(self, span, fname): + '''Called when parser finished processing a file. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the include directive + or None if called the first time for the main input. + fname (str): Name of the file. + ''' + self._log_event('endinclude', span, filename=fname) + + + def handle_setvar(self, span, name, expr): + '''Called when parser encounters a setvar directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the variable. + expr (str): String representation of the expression to be assigned + to the variable. + ''' + self._log_event('setvar', span, name=name, expression=expr) + + + def handle_def(self, span, name, args): + '''Called when parser encounters a def directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the macro to be defined. + args (list of str): Name of the macro arguments. + ''' + self._log_event('def', span, name=name, arguments=args) + + + def handle_enddef(self, span, name): + '''Called when parser encounters an enddef directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name found after the enddef directive. + ''' + self._log_event('enddef', span, name=name) + + + def handle_if(self, span, cond): + '''Called when parser encounters an if directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + cond (str): String representation of the branching condition. + ''' + self._log_event('if', span, condition=cond) + + + def handle_elif(self, span, cond): + '''Called when parser encounters an elif directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + cond (str): String representation of the branching condition. + ''' + self._log_event('elif', span, condition=cond) + + + def handle_else(self, span): + '''Called when parser encounters an else directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('else', span) + + + def handle_endif(self, span): + '''Called when parser encounters an endif directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('endif', span) + + + def handle_for(self, span, varexpr, iterator): + '''Called when parser encounters a for directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + varexpr (str): String representation of the loop variable + expression. + iterator (str): String representation of the iterable. + ''' + self._log_event('for', span, variable=varexpr, iterable=iterator) + + + def handle_endfor(self, span): + '''Called when parser encounters an endfor directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('endfor', span) + + + def handle_call(self, span, macro): + '''Called when parser encounters a call directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + macro (str): Macro to call. + ''' + self._log_event('call', span, macro=macro) + + + def handle_nextarg(self, span): + '''Called when parser encounters a nextarg directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('nextarg', span) + + + def handle_endcall(self, span): + '''Called when parser encounters an endcall directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('endcall', span) + + + def handle_eval(self, span, expr): + '''Called when parser encounters an eval directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + expr (str): String representation of the Python expression to + be evaluated. + ''' + self._log_event('eval', span, expression=expr) + + + def handle_text(self, span, txt): + '''Called when parser finds text which must left unaltered. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + txt (str): Text. + ''' + self._log_event('text', span, content=txt) + + + def handle_comment(self, span): + '''Called when parser finds a preprocessor comment. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('comment', span) + + + def handle_mute(self, span): + '''Called when parser finds a mute directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('mute', span) + + + def handle_endmute(self, span): + '''Called when parser finds an endmute directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('endmute', span) + + + def handle_stop(self, span, msg): + '''Called when parser finds an stop directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + msg (str): Stop message. + ''' + self._log_event('stop', span, msg=msg) + + + def handle_assert(self, span): + '''Called when parser finds an assert directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._log_event('assert', span) + + + @staticmethod + def _log_event(event, span=(-1, -1), **params): + print('{}: {} --> {}'.format(event, span[0], span[1])) + for parname, parvalue in params.items(): + print(' {}: ->|{}|<-'.format(parname, parvalue)) + print() + + + def _parse(self, txt, linenr=0, linedirs=True): + pos = 0 + if linedirs: + regexp = _ALL_DIRECTIVES_REGEXP + else: + regexp = _INLINE_DIRECTIVES_REGEXP + for match in regexp.finditer(txt): + groups = match.groupdict() + start, end = match.span() + if start > pos: + endlinenr = linenr + txt.count('\n', pos, start) + self._process_text(txt[pos:start], (linenr, endlinenr)) + linenr = endlinenr + endlinenr = linenr + txt.count('\n', start, end) + if linedirs and groups['ldirective'] is not None: + self._process_directive( + groups['ldirective'], groups['lparam'], + (linenr, endlinenr)) + elif linedirs and groups['lexpr'] is not None: + self._process_lexpreval(groups['lexpr'], (linenr, endlinenr)) + elif groups['idirective'] is not None: + self._process_directive(groups['idirective'], groups['param'], + (linenr, endlinenr)) + elif groups['iexpr'] is not None: + self._process_iexpreval(groups['iexpr'], (linenr, endlinenr)) + elif linedirs and groups['comment'] is not None: + self.handle_comment((linenr, endlinenr)) + elif linedirs and groups['macro'] is not None: + self._process_directcall( + groups['macro'], groups['macroparams'], (linenr, endlinenr)) + else: + msg = 'internal error: unknown matching pattern' + raise FyppFatalError(msg, self._curfile, (linenr, endlinenr)) + pos = end + linenr = endlinenr + if pos < len(txt): + endlinenr = linenr + txt.count('\n', pos) + self._process_text(txt[pos:], (linenr, endlinenr)) + + + def _process_text(self, txt, span): + escaped_txt = self._unescape(txt) + self.handle_text(span, escaped_txt) + + + def _process_directive(self, directive, param, span): + param = _CONTLINE_REGEXP.sub('', param) + if directive == 'if': + self.handle_if(span, param) + elif directive == 'else': + self._check_empty_param('else', param, span) + self.handle_else(span) + elif directive == 'elif': + self.handle_elif(span, param) + elif directive == 'endif': + self._check_empty_param('endif', param, span) + self.handle_endif(span) + elif directive == 'def': + self._process_def(param, span) + elif directive == 'enddef': + self._process_enddef(param, span) + elif directive == 'setvar' or directive == 'set': + self._process_setvar(param, span) + elif directive == 'for': + self._process_for(param, span) + elif directive == 'endfor': + self._check_empty_param('endfor', param, span) + self.handle_endfor(span) + elif directive == 'call': + self._process_call(param, span) + elif directive == 'nextarg': + self._check_empty_param('nextcall', param, span) + self.handle_nextarg(span) + elif directive == 'endcall': + self._check_empty_param('endcall', param, span) + self.handle_endcall(span) + elif directive == 'include': + self._check_not_inline_directive('include', span) + self._process_include(param, span) + elif directive == 'mute': + self._check_empty_param('mute', param, span) + self._check_not_inline_directive('mute', span) + self.handle_mute(span) + elif directive == 'endmute': + self._check_empty_param('endmute', param, span) + self._check_not_inline_directive('endmute', span) + self.handle_endmute(span) + elif directive == 'stop': + self._check_not_inline_directive('stop', span) + self.handle_stop(span, param) + elif directive == 'assert': + self._check_not_inline_directive('assert', span) + self.handle_assert(span, param) + else: + msg = "unknown directive '{}'".format(directive) + raise FyppFatalError(msg, self._curfile, span) + + + def _process_lexpreval(self, expr, span): + expr = _CONTLINE_REGEXP.sub('', expr) + self.handle_eval(span, expr) + + + def _process_iexpreval(self, expr, span): + self.handle_eval(span, expr) + + + def _process_directcall(self, macroname, macroparams, span): + macroparams = _CONTLINE_REGEXP.sub('', macroparams) + self._process_call(macroname, span) + args = [arg.strip() for arg in macroparams.split('@@')] + if len(args): + linenr = span[0] + self._parse(args[0], linenr=linenr, linedirs=False) + for arg in args[1:]: + self.handle_nextarg(span) + self._parse(arg, linenr=linenr, linedirs=False) + self.handle_endcall(span) + + + def _process_def(self, param, span): + match = _DEF_PARAM_REGEXP.search(param) + if not match: + msg = "invalid macro definition '{}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + name = match.group('name') + argstr = match.group('args') + if argstr is None: + args = [] + else: + args = [s.strip() for s in argstr.split(',')] + self.handle_def(span, name, args) + + + def _process_enddef(self, param, span): + match = _ENDDEF_PARAM_REGEXP.search(param) + if not match: + msg = "invalid enddef parameter '{}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + name = match.group('name') + self.handle_enddef(span, name) + + + def _process_setvar(self, param, span): + match = _SETVAR_PARAM_REGEXP.search(param) + if not match: + msg = "invalid variable assignment '{}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + self.handle_setvar(span, match.group('name'), match.group('expr')) + + + def _process_for(self, param, span): + match = _FOR_PARAM_REGEXP.search(param) + if not match: + msg = "invalid for loop declaration '{}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + loopexpr = match.group('loopexpr') + loopvars = [s.strip() for s in loopexpr.split(',')] + self.handle_for(span, loopvars, match.group('iter')) + + + def _process_call(self, param, span): + match = _CALL_PARAM_REGEXP.search(param) + if not match: + msg = "invalid macro call '{}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + name = match.group('name') + self.handle_call(span, name) + + + def _process_include(self, param, span): + match = _INCLUDE_PARAM_REGEXP.search(param) + if not match: + msg = "invalid include file declaration '{}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + fname = match.group('fname') + for incdir in [self._curdir] + self._includedirs: + fpath = os.path.join(incdir, fname) + if os.path.exists(fpath): + break + else: + msg = "include file '{}' not found".format(fname) + raise FyppFatalError(msg, self._curfile, span) + inpfp = _open_input_file(fpath) + self._includefile(span, inpfp, fpath, os.path.dirname(fpath)) + inpfp.close() + + + def _process_mute(self, span): + if span[0] == span[1]: + msg = 'Inline form of mute directive not allowed' + raise FyppFatalError(msg, self._curfile, span) + self.handle_mute(span) + + + def _process_endmute(self, span): + if span[0] == span[1]: + msg = 'Inline form of endmute directive not allowed' + raise FyppFatalError(msg, self._curfile, span) + self.handle_endmute(span) + + + def _check_empty_param(self, directive, param, span): + if param.strip(): + msg = 'superfluous data in {} directive'.format(directive) + raise FyppFatalError(msg, self._curfile, span) + + def _check_not_inline_directive(self, directive, span): + if span[0] == span[1]: + msg = 'Inline form of {} directive not allowed'.format(directive) + raise FyppFatalError(msg, self._curfile, span) + + + @staticmethod + def _unescape(txt): + txt = _UNESCAPE_REGEXP1.sub(r'\1\2\3', txt) + txt = _UNESCAPE_REGEXP2.sub(r'\1\2\3', txt) + txt = _UNESCAPE_REGEXP3.sub(r'\1\2\3', txt) + return txt + + +class Builder: + '''Builds a tree representing a text with preprocessor directives. + ''' + + def __init__(self): + # The tree, which should be built. + self._tree = [] + + # List of all open constructs + self._open_blocks = [] + + # Nodes to which the open blocks have to be appended when closed + self._path = [] + + # Nr. of open blocks when file was opened. Used for checking whether all + # blocks have been closed, when file processing finishes. + self._nr_prev_blocks = [] + + # Current node, to which content should be added + self._curnode = self._tree + + # Current file + self._curfile = None + + + def reset(self): + '''Resets the builder so that it starts to build a new tree.''' + self._tree = [] + self._open_blocks = [] + self._path = [] + self._nr_prev_blocks = [] + self._curnode = self._tree + self._curfile = None + + + def handle_include(self, span, fname): + '''Should be called to signalize change to new file. + + Args: + span (tuple of int): Start and end line of the include directive + or None if called the first time for the main input. + fname (str): Name of the file to be included. + ''' + self._path.append(self._curnode) + self._curnode = [] + self._open_blocks.append( + ('include', self._curfile, [span], fname, None)) + self._curfile = fname + self._nr_prev_blocks.append(len(self._open_blocks)) + + + def handle_endinclude(self, span, fname): + '''Should be called when processing of a file finished. + + Args: + span (tuple of int): Start and end line of the include directive + or None if called the first time for the main input. + fname (str): Name of the file which has been included. + ''' + nprev_blocks = self._nr_prev_blocks.pop(-1) + if len(self._open_blocks) > nprev_blocks: + directive, fname, spans = self._open_blocks[-1][0:3] + msg = '{} directive in line {} still unclosed when reaching end '\ + 'of file'.format(directive, spans[0][0] + 1) + raise FyppFatalError(msg, self._curfile) + block = self._open_blocks.pop(-1) + directive, blockfname, spans = block[0:3] + if directive != 'include': + msg = 'internal error: last open block is not \'include\' when '\ + 'closing file \'{}\''.format(fname) + raise FyppFatalError(msg) + if span != spans[0]: + msg = 'internal error: span for include and endinclude differ ('\ + '{} vs {}'.format(span, spans[0]) + raise FyppFatalError(msg) + oldfname, _ = block[3:5] + if fname != oldfname: + msg = 'internal error: mismatching file name in close_file event'\ + " (expected: '{}', got: '{}')".format(oldfname, fname) + raise FyppFatalError(msg, fname) + block = directive, blockfname, spans, fname, self._curnode + self._curnode = self._path.pop(-1) + self._curnode.append(block) + self._curfile = blockfname + + + def handle_if(self, span, cond): + '''Should be called to signalize an if directive. + + Args: + span (tuple of int): Start and end line of the directive. + param (str): String representation of the branching condition. + ''' + self._path.append(self._curnode) + self._curnode = [] + self._open_blocks.append(('if', self._curfile, [span], [cond], [])) + + + def handle_elif(self, span, cond): + '''Should be called to signalize an elif directive. + + Args: + span (tuple of int): Start and end line of the directive. + cond (str): String representation of the branching condition. + ''' + self._check_for_open_block(span, 'elif') + block = self._open_blocks[-1] + directive, _, spans = block[0:3] + self._check_if_matches_last(directive, 'if', spans[-1], span, 'elif') + conds, contents = block[3:5] + conds.append(cond) + contents.append(self._curnode) + spans.append(span) + self._curnode = [] + + + def handle_else(self, span): + '''Should be called to signalize an else directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._check_for_open_block(span, 'else') + block = self._open_blocks[-1] + directive, _, spans = block[0:3] + self._check_if_matches_last(directive, 'if', spans[-1], span, 'else') + conds, contents = block[3:5] + conds.append('True') + contents.append(self._curnode) + spans.append(span) + self._curnode = [] + + + def handle_endif(self, span): + '''Should be called to signalize an endif directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._check_for_open_block(span, 'endif') + block = self._open_blocks.pop(-1) + directive, _, spans = block[0:3] + self._check_if_matches_last(directive, 'if', spans[-1], span, 'endif') + _, contents = block[3:5] + contents.append(self._curnode) + spans.append(span) + self._curnode = self._path.pop(-1) + self._curnode.append(block) + + + def handle_for(self, span, loopvar, iterator): + '''Should be called to signalize a for directive. + + Args: + span (tuple of int): Start and end line of the directive. + varexpr (str): String representation of the loop variable + expression. + iterator (str): String representation of the iterable. + ''' + self._path.append(self._curnode) + self._curnode = [] + self._open_blocks.append(('for', self._curfile, [span], loopvar, + iterator, None)) + + + def handle_endfor(self, span): + '''Should be called to signalize an endfor directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._check_for_open_block(span, 'endfor') + block = self._open_blocks.pop(-1) + directive, fname, spans = block[0:3] + self._check_if_matches_last(directive, 'for', spans[-1], span, 'endfor') + loopvar, iterator, dummy = block[3:6] + spans.append(span) + block = (directive, fname, spans, loopvar, iterator, self._curnode) + self._curnode = self._path.pop(-1) + self._curnode.append(block) + + + def handle_def(self, span, name, args): + '''Should be called to signalize a def directive. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the macro to be defined. + args (list of str): Name of the macro arguments. + ''' + self._path.append(self._curnode) + self._curnode = [] + defblock = ('def', self._curfile, [span], name, args, None) + self._open_blocks.append(defblock) + + + def handle_enddef(self, span, name): + '''Should be called to signalize an enddef directive. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the enddef statement. Could be None, if enddef + was specified without name. + ''' + self._check_for_open_block(span, 'enddef') + block = self._open_blocks.pop(-1) + directive, fname, spans = block[0:3] + self._check_if_matches_last(directive, 'def', spans[-1], span, 'enddef') + defname, args, dummy = block[3:6] + if name is not None and name != defname: + msg = "wrong name in enddef directive "\ + "(expected '{}', got '{}')".format(defname, name) + raise FyppFatalError(msg, fname, span) + spans.append(span) + block = (directive, fname, spans, defname, args, self._curnode) + self._curnode = self._path.pop(-1) + self._curnode.append(block) + + + def handle_call(self, span, name): + '''Should be called to signalize a call directive. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the macro to call. + ''' + self._path.append(self._curnode) + self._curnode = [] + self._open_blocks.append(('call', self._curfile, [span], name, [])) + + + def handle_nextarg(self, span): + '''Should be called to signalize a nextarg directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._check_for_open_block(span, 'nextarg') + block = self._open_blocks[-1] + directive, _, spans = block[0:3] + self._check_if_matches_last(directive, 'call', spans[-1], span, + 'endcall') + _, contents = block[3:5] + contents.append(self._curnode) + spans.append(span) + self._curnode = [] + + + def handle_endcall(self, span): + '''Should be called to signalize an endcall directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._check_for_open_block(span, 'endcall') + block = self._open_blocks.pop(-1) + directive, _, spans = block[0:3] + self._check_if_matches_last(directive, 'call', spans[-1], span, + 'endcall') + _, contents = block[3:5] + contents.append(self._curnode) + spans.append(span) + self._curnode = self._path.pop(-1) + self._curnode.append(block) + + + def handle_setvar(self, span, name, expr): + '''Should be called to signalize a setvar directive. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the variable. + expr (str): String representation of the expression to be assigned + to the variable. + ''' + self._curnode.append(('setvar', self._curfile, span, name, expr)) + + + def handle_eval(self, span, expr): + '''Should be called to signalize an eval directive. + + Args: + span (tuple of int): Start and end line of the directive. + expr (str): String representation of the Python expression to + be evaluated. + ''' + self._curnode.append(('eval', self._curfile, span, expr)) + + + def handle_comment(self, span): + '''Should be called to signalize a comment directive. + + The content of the comment is not needed by the builder, but it needs + the span of the comment to generate proper line numbers if needed. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._curnode.append(('comment', self._curfile, span)) + + + def handle_text(self, span, txt): + '''Should be called to pass text which goes to output unaltered. + + Args: + span (tuple of int): Start and end line of the text. + txt (str): Text. + ''' + self._curnode.append(('txt', self._curfile, span, txt)) + + + def handle_mute(self, span): + '''Should be called to signalize a mute directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._path.append(self._curnode) + self._curnode = [] + self._open_blocks.append(('mute', self._curfile, [span], None)) + + + def handle_endmute(self, span): + '''Should be called to signalize an endmute directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._check_for_open_block(span, 'endmute') + block = self._open_blocks.pop(-1) + directive, fname, spans = block[0:3] + self._check_if_matches_last(directive, 'mute', spans[-1], span, + 'endmute') + spans.append(span) + block = (directive, fname, spans, self._curnode) + self._curnode = self._path.pop(-1) + self._curnode.append(block) + + + def handle_stop(self, span, msg): + '''Should be called to signalize a stop directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._curnode.append(('stop', self._curfile, span, msg)) + + + def handle_assert(self, span, cond): + '''Should be called to signalize an assert directive. + + Args: + span (tuple of int): Start and end line of the directive. + ''' + self._curnode.append(('assert', self._curfile, span, cond)) + + + @property + def tree(self): + '''Returns the tree built by the Builder.''' + return self._tree + + + def _check_for_open_block(self, span, directive): + if len(self._open_blocks) <= self._nr_prev_blocks[-1]: + msg = 'unexpected {} directive'.format(directive) + raise FyppFatalError(msg, self._curfile, span) + + + def _check_if_matches_last(self, lastdir, curdir, lastspan, curspan, + directive): + if curdir != lastdir: + msg = 'mismatching {} directive'.format(directive) + raise FyppFatalError(msg, self._curfile, curspan) + inline_last = lastspan[0] == lastspan[1] + inline_cur = curspan[0] == curspan[1] + if inline_last != inline_cur: + if inline_cur: + msg = 'expecting line form of directive {}'.format(directive) + else: + msg = 'expecting inline form of directive {}'.format(directive) + raise FyppFatalError(msg, self._curfile, curspan) + elif inline_cur and curspan[0] != lastspan[0]: + msg = 'inline directives of the same construct must be in the '\ + 'same row' + raise FyppFatalError(msg, self._curfile, curspan) + + +class Renderer: + + ''''Renders a tree. + + Args: + evaluator (Evaluator, optional): Evaluator to use when rendering eval + directives. If None (default), Evaluator() is used. + linenums (bool, optional): Whether linenums should be generated, + defaults to False. + contlinenums (bool, optional): Whether linenums for continuation + should be generated, defaults to False. + linefolder (callable): Callable to use when folding a line. + ''' + + def __init__(self, evaluator=None, linenums=False, contlinenums=False, + linefolder=None): + # Evaluator to use for Python expressions + self._evaluator = Evaluator() if evaluator is None else evaluator + self._evaluator.updateenv(_DATE_=time.strftime('%Y-%m-%d'), + _TIME_=time.strftime('%H:%M:%S')) + + # Number of diversions, when > 0 we are within a macro call + self._diversions = 0 + + # Whether line numbering directives should be emitted + self._linenums = linenums + + # Whether line numbering directives in continuation lines are needed. + self._contlinenums = contlinenums + + # Callable to be used for folding lines + if linefolder is None: + self._linefolder = lambda line: [line] + else: + self._linefolder = linefolder + + + def render(self, tree, env=None): + '''Renders a tree. + + Args: + tree (fypp-tree): Tree to render. + env (dict, optional): Dictionary containing additional definitions + for the evaluator. The definitions are removed from the + the evaluator, once the rendering finished. + + Returns: + str: Rendered string. + ''' + output, eval_inds, eval_pos = self._render(tree, env) + if eval_inds: + self._postprocess_eval_lines(output, eval_inds, eval_pos) + txt = ''.join(output) + return txt + + + def _render(self, tree, env=None): + newscope = env is not None + if newscope: + self._evaluator.pushenv(env) + output = [] + eval_inds = [] + eval_pos = [] + for node in tree: + cmd = node[0] + if cmd == 'txt': + output.append(node[3]) + elif cmd == 'if': + out, ieval, peval = self._get_conditional_content(*node[1:5]) + eval_inds += _shiftinds(ieval, len(output)) + eval_pos += peval + output += out + elif cmd == 'eval': + out, ieval, peval = self._get_eval(*node[1:4]) + eval_inds += _shiftinds(ieval, len(output)) + eval_pos += peval + output += out + elif cmd == 'def': + result = self._define_macro(*node[1:6]) + output.append(result) + elif cmd == 'setvar': + result = self._define_variable(*node[1:5]) + output.append(result) + elif cmd == 'for': + out, ieval, peval = self._get_iterated_content(*node[1:6]) + eval_inds += _shiftinds(ieval, len(output)) + eval_pos += peval + output += out + elif cmd == 'call': + out, ieval, peval = self._get_called_content(*node[1:5]) + eval_inds += _shiftinds(ieval, len(output)) + eval_pos += peval + output += out + elif cmd == 'include': + out, ieval, peval = self._get_included_content(*node[1:5]) + eval_inds += _shiftinds(ieval, len(output)) + eval_pos += peval + output += out + elif cmd == 'comment': + output.append(self._get_comment(*node[1:3])) + elif cmd == 'mute': + output.append(self._get_muted_content(*node[1:4])) + elif cmd == 'stop': + self._handle_stop(*node[1:4]) + elif cmd == 'assert': + result = self._handle_assert(*node[1:4]) + output.append(result) + else: + msg = "internal error: unknown command '{}'".format(cmd) + raise FyppFatalError(msg) + if newscope: + self._evaluator.popenv() + return output, eval_inds, eval_pos + + + def _get_eval(self, fname, span, expr): + self._update_linenr(span[0]) + try: + result = self._evaluator.evaluate(expr) + except Exception as exc: + msg = "exception occured when evaluating '{}'".format(expr) + raise FyppFatalError(msg, fname, span, exc) + out = [] + ieval = [] + peval = [] + if result is not None: + out.append(str(result)) + if not self._diversions: + ieval.append(0) + peval.append((span, fname)) + if span[0] != span[1]: + out.append('\n') + return out, ieval, peval + + + def _get_conditional_content(self, fname, spans, conditions, contents): + out = [] + ieval = [] + peval = [] + multiline = (spans[0][0] != spans[-1][1]) + for condition, content, span in zip(conditions, contents, spans): + self._update_linenr(span[1]) + try: + cond = bool(self._evaluator.evaluate(condition)) + except Exception as exc: + msg = "exception occured when evaluating '{}'"\ + .format(condition) + raise FyppFatalError(msg, fname, span, exc) + if cond: + if self._linenums and not self._diversions and multiline: + out.append(linenumdir(span[1], fname)) + outcont, ievalcont, pevalcont = self._render(content) + ieval += _shiftinds(ievalcont, len(out)) + peval += pevalcont + out += outcont + break + if self._linenums and not self._diversions and multiline: + out.append(linenumdir(spans[-1][1], fname)) + return out, ieval, peval + + + def _get_iterated_content(self, fname, spans, loopvars, loopiter, content): + out = [] + ieval = [] + peval = [] + self._update_linenr(spans[0][1]) + try: + iterobj = iter(self._evaluator.evaluate(loopiter)) + except Exception as exc: + msg = "exception occured when evaluating '{}'"\ + .format(loopiter) + raise FyppFatalError(msg, fname, spans[0], exc) + multiline = (spans[0][0] != spans[-1][1]) + for var in iterobj: + if len(loopvars) == 1: + loopscope = {loopvars[0]: var} + else: + loopscope = {varname: value + for varname, value in zip(loopvars, var)} + if self._linenums and not self._diversions and multiline: + out.append(linenumdir(spans[0][1], fname)) + outcont, ievalcont, pevalcont = self._render(content, loopscope) + ieval += _shiftinds(ievalcont, len(out)) + peval += pevalcont + out += outcont + if self._linenums and not self._diversions and multiline: + out.append(linenumdir(spans[1][1], fname)) + return out, ieval, peval + + + def _get_called_content(self, fname, spans, name, contents): + args = [] + self._divert() + for content in contents: + out = self.render(content, {}) + if len(out) and out[-1] == '\n': + out = out[:-1] + out_escaped = out.replace('\\', '\\\\') + out_escaped = out_escaped.replace('"', r'\"') + args.append('"""' + out_escaped + '"""') + self._undivert() + expr = "{}({})".format(name, ','.join(args)) + out, ieval, peval = self._get_eval( + fname, (spans[0][0], spans[-1][1]), expr) + return out, ieval, peval + + + def _get_included_content(self, fname, spans, includefname, content): + out = [] + self._evaluator.updateenv(_FILE_=includefname) + if self._linenums and not self._diversions: + out += linenumdir(0, includefname, 1) + outcont, ieval, peval = self._render(content) + ieval = _shiftinds(ieval, len(out)) + out += outcont + self._evaluator.updateenv(_FILE_=fname) + if self._linenums and not self._diversions and spans[0] is not None: + out += linenumdir(spans[0][1], fname, 2) + return out, ieval, peval + + + def _define_macro(self, fname, spans, name, args, content): + result = '' + try: + macro = _Macro(name, fname, spans, args, content, self.render, + self._divert, self._undivert) + self._evaluator.define(name, macro) + except Exception as exc: + msg = "exception occured when defining macro '{}'"\ + .format(name) + raise FyppFatalError(msg, fname, spans[0], exc) + if self._linenums and not self._diversions: + result = linenumdir(spans[1][1], fname) + return result + + + def _define_variable(self, fname, span, name, valstr): + result = '' + self._update_linenr(span[0]) + try: + self._evaluator.define(name, self._evaluator.evaluate(valstr)) + except Exception as exc: + msg = "exception occured when setting variable(s) {} to {}"\ + .format(name, valstr) + raise FyppFatalError(msg, fname, span, exc) + multiline = (span[0] != span[1]) + if self._linenums and not self._diversions and multiline: + result = linenumdir(span[1], fname) + return result + + + def _get_comment(self, fname, span): + if self._linenums and not self._diversions: + return linenumdir(span[1], fname) + else: + return '' + + + def _get_muted_content(self, fname, spans, content): + self._render(content) + if self._linenums and not self._diversions: + return linenumdir(spans[-1][1], fname) + else: + return '' + + + def _handle_stop(self, fname, span, msgstr): + self._update_linenr(span[0]) + try: + msg = str(self._evaluator.evaluate(msgstr)) + except Exception as exc: + msg = "exception occured when evaluating stop message '{}'"\ + .format(msgstr) + raise FyppFatalError(msg, fname, span, exc) + raise FyppStopRequest(msg, fname, span) + + + def _handle_assert(self, fname, span, expr): + result = '' + self._update_linenr(span[0]) + try: + cond = bool(self._evaluator.evaluate(expr)) + except Exception as exc: + msg = "exception occured when evaluating assert condition '{}'"\ + .format(expr) + raise FyppFatalError(msg, fname, span, exc) + if not cond: + msg = "Assertion failed ('{}')".format(expr) + raise FyppStopRequest(msg, fname, span) + if self._linenums and not self._diversions: + result = linenumdir(span[1], fname) + return result + + + def _divert(self): + self._diversions += 1 + + + def _undivert(self): + self._diversions -= 1 + if self._diversions < 0: + msg = "Internal error: undivert without matching divert" + raise FyppFatalError(msg) + + + def _update_linenr(self, linenr): + if not self._diversions: + self._evaluator.updateenv(_LINE_=linenr + 1) + + + def _postprocess_eval_lines(self, output, eval_inds, eval_pos): + ilastproc = -1 + for ieval, ind in enumerate(eval_inds): + span, fname = eval_pos[ieval] + if ind <= ilastproc: + continue + iprev, eolprev = self._find_last_eol(output, ind) + inext, eolnext = self._find_next_eol(output, ind) + curline = self._glue_line(output, ind, iprev, eolprev, inext, + eolnext) + output[iprev + 1:inext] = [''] * (inext - iprev - 1) + output[ind] = self._postprocess_eval_line(curline, fname, span) + ilastproc = inext + + + @staticmethod + def _find_last_eol(output, ind): + 'Find last newline before current position.' + iprev = ind - 1 + while iprev >= 0: + eolprev = output[iprev].rfind('\n') + if eolprev != -1: + break + iprev -= 1 + else: + iprev = 0 + eolprev = -1 + return iprev, eolprev + + + @staticmethod + def _find_next_eol(output, ind): + 'Find last newline before current position.' + # find first eol after expr. evaluation + inext = ind + 1 + while inext < len(output): + eolnext = output[inext].find('\n') + if eolnext != -1: + break + inext += 1 + else: + inext = len(output) - 1 + eolnext = len(output[-1]) - 1 + return inext, eolnext + + + @staticmethod + def _glue_line(output, ind, iprev, eolprev, inext, eolnext): + 'Create line from parts between specified boundaries.' + curline_parts = [] + if iprev != ind: + curline_parts = [output[iprev][eolprev + 1:]] + output[iprev] = output[iprev][:eolprev + 1] + curline_parts.extend(output[iprev + 1:ind]) + curline_parts.extend(output[ind]) + curline_parts.extend(output[ind + 1:inext]) + if inext != ind: + curline_parts.append(output[inext][:eolnext + 1]) + output[inext] = output[inext][eolnext + 1:] + return ''.join(curline_parts) + + + def _postprocess_eval_line(self, evalline, fname, span): + lines = evalline.split('\n') + # If line ended on '\n', last element is ''. We remove it and + # add the trailing newline later manually. + trailing_newline = (lines[-1] == '') + if trailing_newline: + del lines[-1] + lnum = linenumdir(span[0], fname) if self._linenums else '' + clnum = lnum if self._contlinenums else '' + linenumsep = '\n' + lnum + clinenumsep = '\n' + clnum + foldedlines = [self._foldline(line) for line in lines] + outlines = [clinenumsep.join(lines) for lines in foldedlines] + result = linenumsep.join(outlines) + # Add missing trailing newline + if trailing_newline: + trailing = '\n' + if self._linenums: + # Last line was folded, but no linenums were generated for + # the continuation lines -> current line position is not + # in sync with the one calculated from the last line number + unsync = ( + len(foldedlines) and len(foldedlines[-1]) > 1 + and not self._contlinenums) + # Eval directive in source consists of more than one line + multiline = span[1] - span[0] > 1 + if unsync or multiline: + # For inline eval directives span[0] == span[1] + # -> next line is span[0] + 1 and not span[1] as for + # line eval directives + nextline = max(span[1], span[0] + 1) + trailing += linenumdir(nextline, fname) + else: + trailing = '' + return result + trailing + + + def _foldline(self, line): + if _COMMENTLINE_REGEXP.match(line) is None: + return self._linefolder(line) + else: + return [line] + + +class Evaluator: + + '''Provides an isolated environment for evaluating Python expressions. + + It can restrict the builtins which can be used within this environment + to a (hopefully safe) subset. Additionally it defines the functions + which are provided by the preprocessor for the eval directives. + + Note, that the restricted environment does not allow importing Python + modules. If you need a restricted environment with modules loaded, + launch a non-restricted one, load the modules, export its environment + and launch a restricted one using that environment. + + Args: + env (dict, optional): Initial definitions for the environment, defaults + to None. + restricted (bool, optional): Whether the restricted builtins should + be used. Otherwise all Python builtins are accessible. Defaults to + `True` (restricted environment. + ''' + + RESTRICTED_BUILTINS = { + 'abs': builtins.abs, + 'all': builtins.all, + 'any': builtins.any, + 'bin': builtins.bin, + 'bool': builtins.bool, + 'bytearray': builtins.bytearray, + 'bytes': builtins.bytes, + 'callable': builtins.callable, + 'chr': builtins.chr, + 'classmethod': builtins.classmethod, + 'complex': builtins.complex, + 'delattr': builtins.delattr, + 'dict': builtins.dict, + 'dir': builtins.dir, + 'divmod': builtins.divmod, + 'enumerate': builtins.enumerate, + 'filter': builtins.filter, + 'float': builtins.float, + 'format': builtins.format, + 'frozenset': builtins.frozenset, + 'getattr': builtins.getattr, + 'globals': builtins.globals, + 'hasattr': builtins.hasattr, + 'hash': builtins.hash, + 'hex': builtins.hex, + 'id': builtins.id, + 'int': builtins.int, + 'isinstance': builtins.isinstance, + 'issubclass': builtins.issubclass, + 'iter': builtins.iter, + 'len': builtins.len, + 'list': builtins.list, + 'locals': builtins.locals, + 'map': builtins.map, + 'max': builtins.max, + 'memoryview': builtins.memoryview, + 'min': builtins.min, + 'next': builtins.next, + 'object': builtins.object, + 'oct': builtins.oct, + 'ord': builtins.ord, + 'pow': builtins.pow, + 'property': builtins.property, + 'range': builtins.range, + 'repr': builtins.repr, + 'reversed': builtins.reversed, + 'round': builtins.round, + 'set': builtins.set, + 'setattr': builtins.setattr, + 'slice': builtins.slice, + 'sorted': builtins.sorted, + 'staticmethod': builtins.staticmethod, + 'str': builtins.str, + 'sum': builtins.sum, + 'super': builtins.super, + 'tuple': builtins.tuple, + 'type': builtins.type, + 'vars': builtins.vars, + 'zip': builtins.zip, + # For Python2 True/False must be explicitely added + 'True': True, + 'False': False, + } + + def __init__(self, env=None, restricted=True): + # Definitions (environment) to use when evaluating expressions + self._env = env.copy() if env is not None else {} + + # Stack for environments to implement nested scopes + self._envstack = [] + + if restricted: + builtindict = {} + builtindict.update(self.RESTRICTED_BUILTINS) + builtindict['__import__'] = self._func_import + else: + builtindict = vars(builtins) + builtindict['defined'] = self._func_defined + builtindict['setvar'] = self._func_setvar + builtindict['getvar'] = self._func_getvar + + # Permitted builtins when evaluating expressions + self._builtins = {'__builtins__': builtindict} + + + def evaluate(self, expr): + '''Evaluate a Python expression using the `eval()` builtin. + + Args: + expr (str): String represantion of the expression. + + Return: + Python object: Result of the expression evaluation. + ''' + result = eval(expr, self._builtins, self._env) + return result + + + def execute(self, code): + '''Run Python code using the `exec()` builtin. + + Args: + code (str): Python code to run. + ''' + exec(code, self._builtins, self._env) + + + def define(self, name, value): + '''Define a Python entity. + + Args: + name (str): Name of the entity. + value (Python object): Value of the entity. + + Raises: + FyppFatalError: If name starts with the reserved prefix or if it is a + reserved name. + ''' + lpar = name.startswith('(') + rpar = name.endswith(')') + if lpar != rpar: + msg = "unbalanced paranthesis around variable name(s) in '{}'"\ + .format(name) + raise FyppFatalError(msg, None, None) + if lpar: + name = name[1:-1] + varnames = [s.strip() for s in name.split(',')] + if len(varnames) == 1: + value = (value,) + for ind, varname in enumerate(varnames): + if varname.startswith(_RESERVED_PREFIX): + msg = "Name '{}' starts with reserved prefix '{}'"\ + .format(varname, _RESERVED_PREFIX) + raise FyppFatalError(msg, None, None) + if varname in _RESERVED_NAMES: + msg = "Name '{}' is reserved and can not be redefined"\ + .format(varname) + raise FyppFatalError(msg, None, None) + self._env[varname] = value[ind] + + + def updateenv(self, **vardict): + '''Add variables to the environment. + + Args: + **vardict: variable defintions. + ''' + self._env.update(vardict) + + + def pushenv(self, vardict): + '''Push current environment to stack, and use its copy with additional + new defintions instead. + + Args: + vardict (dict): New variables. + ''' + self._envstack.append(self._env) + self._env = self._env.copy() + self._env.update(vardict) + + + def popenv(self): + '''Replace current environment with pop last one from stack.''' + self._env = self._envstack.pop(-1) + + + @property + def env(self): + '''Return current environment.''' + return self._env + + + def _func_defined(self, var): + return var in self._env + + + def _func_import(self, name, *_, **__): + module = self._env.get(name, None) + if module is not None and isinstance(module, types.ModuleType): + return module + else: + msg = "Import of module '{}' via '__import__' not allowed" \ + .format(name) + raise ImportError(msg) + + + def _func_setvar(self, name, value): + self.define(name, value) + return '' + + + def _func_getvar(self, name, defvalue): + if name in self._env: + return self._env[name] + else: + return defvalue + + +class _Macro: + + '''Represents a user defined macro. + + Args: + name (str): Name of the macro. + fname (str): The file where the macro was defined. + spans (str): Line spans of macro defintion. + argnames (list of str): Macro dummy arguments. + content (list): Content of the macro as tree. + renderfunc (function): Function to call when content should be rendered. + This is typically the corresponding render routine of the Builder. + divert (function): Function to call when macro rendering started, in + order to suppress its output. Typically the corresponding routine + of the Builder. + undivert (function): Function to call when macro rendering finished. + Typically the corresponding routine of the Builder. + ''' + + def __init__(self, name, fname, spans, argnames, content, renderfunc, + divert, undivert): + self._name = name + self._fname = fname + self._spans = spans + self._argnames = argnames + self._content = content + self._renderfunc = renderfunc + self._divert = divert + self._undivert = undivert + + + def __call__(self, *args, **keywords): + self._divert() + if len(args) != len(self._argnames): + msg = "Macro '{}' received incorrect nr. of positional arguments " \ + "(expected: {}, received: {})".format( + self._name, len(self._argnames), len(args)) + raise FyppFatalError(msg, self._fname, self._spans[0]) + argdict = {} + for argname, arg in zip(self._argnames, args): + argdict[argname] = arg + argdict.update(keywords) + output = self._renderfunc(self._content, argdict) + self._undivert() + if output.endswith('\n'): + return output[:-1] + else: + return output + + +class Processor: + + '''Connects various objects with each other to create a processor. + + Args: + parser (Parser, optional): Parser to use for parsing text. If None + (default), `Parser()` is used. + builder (Builder, optional): Builder to use for building the tree + representation of the text. If None (default), `Builder()` is used. + renderer (Renderer, optional): Renderer to use for rendering the + output. If None (default), `Renderer()` is used with a default + Evaluator(). + evaluator (Evaluator, optional): Evaluator to use for evaluating Python + expressions. If None (default), `Evaluator()` is used. + ''' + + def __init__(self, parser=None, builder=None, renderer=None, + evaluator=None): + self._parser = Parser() if parser is None else parser + self._builder = Builder() if builder is None else builder + if renderer is None: + evaluator = Evaluator() if evaluator is None else evaluator + self._renderer = Renderer(evaluator) + else: + self._renderer = renderer + + self._parser.handle_include = self._builder.handle_include + self._parser.handle_endinclude = self._builder.handle_endinclude + self._parser.handle_if = self._builder.handle_if + self._parser.handle_else = self._builder.handle_else + self._parser.handle_elif = self._builder.handle_elif + self._parser.handle_endif = self._builder.handle_endif + self._parser.handle_eval = self._builder.handle_eval + self._parser.handle_text = self._builder.handle_text + self._parser.handle_def = self._builder.handle_def + self._parser.handle_enddef = self._builder.handle_enddef + self._parser.handle_setvar = self._builder.handle_setvar + self._parser.handle_for = self._builder.handle_for + self._parser.handle_endfor = self._builder.handle_endfor + self._parser.handle_call = self._builder.handle_call + self._parser.handle_nextarg = self._builder.handle_nextarg + self._parser.handle_endcall = self._builder.handle_endcall + self._parser.handle_comment = self._builder.handle_comment + self._parser.handle_mute = self._builder.handle_mute + self._parser.handle_endmute = self._builder.handle_endmute + self._parser.handle_stop = self._builder.handle_stop + self._parser.handle_assert = self._builder.handle_assert + + + def process_file(self, fname, env=None): + '''Processeses a file. + + Args: + fname (str): Name of the file to process. + env (dict): Additional definitons for the evaluator. + + Returns: + str: Processed content. + ''' + self._parser.parsefile(fname) + return self._render(env) + + + def process_text(self, txt, env=None): + '''Processes a string. + + Args: + txt (str): Text to process. + env (dict): Additional definitons for the evaluator. + + Returns: + str: Processed content. + ''' + self._parser.parse(txt) + return self._render(env) + + + def _render(self, env): + env = {} if env is None else env + output = self._renderer.render(self._builder.tree, env) + self._builder.reset() + return ''.join(output) + + +def linenumdir(linenr, fname, flag=None): + '''Returns a line numbering directive. + + Args: + linenr (int): Line nr (starting with 0). + fname (str): File name. + ''' + if flag is None: + return '# {} "{}"\n'.format(linenr + 1, fname) + else: + return '# {} "{}" {}\n'.format(linenr + 1, fname, flag) + + +class Fypp: + + '''Fypp preprocessor. + + You can invoke it like :: + + tool = Fypp() + tool.process_file('file.in', 'file.out') + + to initialize Fypp with default options, process `file.in` and write the + result to `file.out`. If the input should be read from a string, the + ``process_text()`` method can be used:: + + tool = Fypp() + output = tool.process_text('#:if DEBUG > 0\\nprint *, "DEBUG"\\n#:endif\\n') + + If you want to fine tune Fypps behaviour, pass a customized `FyppOptions`_ + instance at initialization:: + + options = FyppOptions() + options.fixed_format = True + tool = Fypp(options) + + Alternatively, you can use the command line parser + ``argparse.ArgumentParser`` to set options for Fypp. The function + ``get_option_parser()`` returns you a default argument parser. You can then + use its ``parse_args()`` method to obtain settings by reading the command + line arguments:: + + options = FyppOptions() + argparser = get_option_parser() + options = argparser.parse_args(namespace=options) + tool = fypp.Fypp(options) + + The command line arguments can also be passed directly as a list when + calling ``parse_args()``:: + + options = FyppOptions() + args = ['-DDEBUG=0', 'input.fpp', 'output.f90'] + argparser = get_option_parser() + options = argparser.parse_args(args=args, namespace=options) + tool = fypp.Fypp(options) + + + Args: + options (object): Object containing the settings for Fypp. You typically + would pass a customized `FyppOptions`_ instance or a ``Namespace`` + object as returned by an argument parser. If not present, the + default settings in `FyppOptions`_ are used. + + ''' + + def __init__(self, options=None): + if options is None: + options = FyppOptions() + inieval = Evaluator(restricted=False) + if options.modules: + self._import_modules(options.modules, inieval) + if options.inifiles: + self._exec_inifiles(options.inifiles, inieval) + evaluator = Evaluator(env=inieval.env, restricted=True) + if options.defines: + self._apply_definitions(options.defines, evaluator) + parser = Parser(options.includes) + builder = Builder() + + fixed_format = options.fixed_format + linefolding = not options.no_folding + if linefolding: + folding = 'brute' if fixed_format else options.folding_mode + linelength = 72 if fixed_format else options.line_length + indentation = 5 if fixed_format else options.indentation + prefix = '&' + suffix = '' if fixed_format else '&' + linefolder = FortranLineFolder(linelength, indentation, folding, + prefix, suffix) + else: + linefolder = DummyLineFolder() + linenums = options.line_numbering + contlinenums = (options.line_numbering_mode != 'nocontlines') + self._create_parent_folder = options.create_parent_folder + renderer = Renderer( + evaluator, linenums=linenums, contlinenums=contlinenums, + linefolder=linefolder) + self._preprocessor = Processor(parser, builder, renderer) + + + def process_file(self, infile, outfile=None, env=None): + '''Processes input file and writes result to output file. + + Args: + infile (str): Name of the file to read and process. If its value is + '-', input is read from stdin. + outfile (str, optional): Name of the file to write the result to. + If its value is '-', result is written to stdout. If not + present, result will be returned as string. + env (dict, optional): Additional definitions for the evaluator. + + Returns: + str: Result of processed input, if no outfile was specified. + ''' + infile = STDIN if infile == '-' else infile + output = self._preprocessor.process_file(infile, env) + if outfile is None: + return output + else: + if outfile == '-': + outfile = sys.stdout + else: + outfile = _open_output_file(outfile, self._create_parent_folder) + outfile.write(output) + if outfile != sys.stdout: + outfile.close() + + + def process_text(self, txt, env=None): + '''Processes a string. + + Args: + txt (str): String to process. + env (dict, optional): Additional definitions for the evaluator. + + Returns: + str: Processed content. + ''' + return self._preprocessor.process_text(txt, env) + + + @staticmethod + def _apply_definitions(defines, evaluator): + for define in defines: + words = define.split('=', 2) + name = words[0] + value = None + if len(words) > 1: + try: + value = evaluator.evaluate(words[1]) + except Exception as exc: + msg = "exception at evaluating '{}' in definition for " \ + "'{}'".format(words[1], name) + raise FyppFatalError(msg, cause=exc) + evaluator.define(name, value) + + + @staticmethod + def _import_modules(modules, evaluator): + for module in modules: + try: + evaluator.execute('import ' + module) + except Exception as exc: + msg = "exception occured during import of module '{}'"\ + .format(module) + raise FyppFatalError(msg, cause=exc) + + + @staticmethod + def _exec_inifiles(inifiles, evaluator): + for inifile in inifiles: + try: + inifp = open(inifile, 'r') + source = inifp.read() + inifp.close() + except IOError as exc: + msg = "IO error occured at reading file '{}'"\ + .format(inifile) + raise FyppFatalError(msg, cause=exc) + try: + code = compile(source, inifile, 'exec', dont_inherit=-1) + evaluator.execute(code) + except Exception as exc: + msg = "exception occured when executing ini-file '{}'"\ + .format(inifile) + raise FyppFatalError(msg, cause=exc) + + +class FyppOptions: + + '''Container for Fypp options with default values. + + Attributes: + defines (list of str): List of variable definitions in the form of + 'VARNAME=VALUE'. Default: [] + includes (list of str): List of paths to search when looking for include + files. Default: [] + line_numbering (bool): Whether line numbering directives should appear + in the output. Default: False + line_numbering_mode (str): Line numbering mode 'full' or 'nocontlines'. + Default: 'full'. + line_length (int): Length of output lines. Default: 132. + folding_mode (str): Folding mode 'smart', 'simple' or 'brute'. Default: + 'smart'. + no_folding (bool): Whether folding should be suppresed. Default: False. + indentation (int): Indentation in continuation lines. Default: 4. + modules (list of str): Modules to import at initialization. Default: []. + inifiles (list of str): Python files to execute at initialization. + Default: [] + fixed_format (bool): Whether input file is in fixed format. + Default: False. + create_parent_folder (bool): Whether the parent folder for the output + file should be created if it does not exist. Default: False. + ''' + + def __init__(self): + self.defines = [] + self.includes = [] + self.line_numbering = False + self.line_numbering_mode = 'full' + self.line_length = 132 + self.folding_mode = 'smart' + self.no_folding = False + self.indentation = 4 + self.modules = [] + self.inifiles = [] + self.fixed_format = False + self.create_parent_folder = False + + +class FortranLineFolder: + + '''Implements line folding with Fortran continuation lines. + + Args: + maxlen (int, optional): Maximal line length (default: 132). + indent (int, optional): Indentation for continuation lines (default: 4). + method (str, optional): Folding method with following options: + + * ``brute``: folding with maximal length of continuation lines, + * ``simple``: indents with respect of indentation of first line, + * ``smart``: like ``simple``, but tries to fold at whitespaces. + + prefix (str, optional): String to use at the beginning of a continuation + line (default: '&'). + suffix (str, optional): String to use at the end of the line preceeding + a continuation line (default: '&') + ''' + + def __init__(self, maxlen=132, indent=4, method='smart', prefix='&', + suffix='&'): + # Line length should be long enough that contintuation lines can host at + # east one character apart of indentation and two continuation signs + minmaxlen = indent + len(prefix) + len(suffix) + 1 + if maxlen < minmaxlen: + msg = 'Maximal line length less than {} when using an indentation' \ + 'of {}'.format(minmaxlen, indent) + raise FyppFatalError(msg) + self._maxlen = maxlen + self._indent = indent + self._prefix = ' ' * self._indent + prefix + self._suffix = suffix + if method not in ['brute', 'smart', 'simple']: + raise FyppFatalError('invalid folding type') + if method == 'brute': + self._inherit_indent = False + self._fold_position_finder = self._get_maximal_fold_pos + elif method == 'simple': + self._inherit_indent = True + self._fold_position_finder = self._get_maximal_fold_pos + elif method == 'smart': + self._inherit_indent = True + self._fold_position_finder = self._get_smart_fold_pos + + + def __call__(self, line): + '''Folds a line. + + Can be directly called to return the list of folded lines:: + + linefolder = FortranLineFolder(maxlen=10) + linefolder(' print *, "some Fortran line"') + + Args: + line (str): Line to fold. + + Returns: + list of str: Components of folded line. They should be + assembled via ``\\n.join()`` to obtain the string + representation. + ''' + if self._maxlen < 0 or len(line) <= self._maxlen: + return [line] + if self._inherit_indent: + indent = len(line) - len(line.lstrip()) + prefix = ' ' * indent + self._prefix + else: + indent = 0 + prefix = self._prefix + suffix = self._suffix + return self._split_line(line, self._maxlen, prefix, suffix, + self._fold_position_finder) + + + @staticmethod + def _split_line(line, maxlen, prefix, suffix, fold_position_finder): + # length of continuation lines with 1 or two continuation chars. + maxlen1 = maxlen - len(prefix) + maxlen2 = maxlen1 - len(suffix) + start = 0 + end = fold_position_finder(line, start, maxlen - len(suffix)) + result = [line[start:end] + suffix] + while end < len(line) - maxlen1: + start = end + end = fold_position_finder(line, start, start + maxlen2) + result.append(prefix + line[start:end] + suffix) + result.append(prefix + line[end:]) + return result + + + @staticmethod + def _get_maximal_fold_pos(_, __, end): + return end + + + @staticmethod + def _get_smart_fold_pos(line, start, end): + linelen = end - start + ispace = line.rfind(' ', start, end) + # The space we waste for smart folding should be max. 1/3rd of the line + if ispace != -1 and ispace >= start + (2 * linelen) // 3: + return ispace + else: + return end + + +class DummyLineFolder: + + '''Implements a dummy line folder returning the line unaltered.''' + + def __call__(self, line): + '''Returns the entire line without any folding. + + Returns: + list of str: Components of folded line. They should be + assembled via ``\\n.join()`` to obtain the string + representation. + ''' + return [line] + + +def get_option_parser(): + '''Returns an option parser for the Fypp command line tool. + + Returns: + ArgumentParser: Parser which can create a namespace object with + Fypp settings based on command line arguments. + ''' + fypp_name = 'fypp' + fypp_desc = 'Preprocess source files with Fypp directives.' + parser = ArgumentParser(prog=fypp_name, description=fypp_desc) + msg = 'define variable, value is interpreted as ' \ + 'Python expression (e.g \'-DDEBUG=1\' sets DEBUG to the ' \ + 'integer 1) or set to None if ommitted' + parser.add_argument('-D', '--define', action='append', dest='defines', + metavar='VAR[=VALUE]', help=msg) + msg = 'add directory to the search paths for include files' + parser.add_argument('-I', '--include', action='append', dest='includes', + metavar='INCDIR', help=msg) + msg = 'put line numbering directives to the output' + parser.add_argument('-n', '--line-numbering', action='store_true', + default=False, help=msg) + msg = 'line numbering mode, \'full\' (default): line numbering '\ + 'directives generated whenever source and output lines are out '\ + 'of sync, \'nocontlines\': line numbering directives omitted '\ + 'for continuation lines' + parser.add_argument('-N', '--line-numbering-mode', metavar='MODE', + choices=['full', 'nocontlines'], default='full', + help=msg) + msg = 'maximal line length (default: 132), lines modified by the '\ + 'preprocessor are folded if becoming longer' + parser.add_argument('-l', '--line-length', type=int, default=132, + metavar='LEN', help=msg) + msg = 'line folding mode, \'smart\' (default): indentation context '\ + 'and whitespace aware, \'simple\': indentation context aware, '\ + '\'brute\': mechnical folding' + parser.add_argument('-f', '--folding-mode', metavar='MODE', + choices=['smart', 'simple', 'brute'], + default='smart', help=msg) + msg = 'suppress line folding' + parser.add_argument('-F', '--no-folding', action='store_true', + dest='no_folding', default=False, help=msg) + msg = 'indentation to use for continuation lines (default 4)' + parser.add_argument('--indentation', type=int, metavar='IND', + default=4, help=msg) + msg = 'import python module before starting the processing' + parser.add_argument('-m', '--module', action='append', dest='modules', + metavar='MOD', help=msg) + msg = 'execute python initialization script before starting processing' + parser.add_argument('-i', '--ini-file', action='append', + dest='inifiles', metavar='INI', help=msg) + msg = 'produce fixed format output (any settings for options '\ + '--line-length, --folding-method and --indentation are ignored)' + parser.add_argument('--fixed-format', action='store_true', + default=False, help=msg) + msg = 'create parent folders of the output file if they do not exist' + parser.add_argument('-p', '--create-parents', action='store_true', + default=False, dest='create_parent_folder', help=msg) + versionstr = '%(prog)s ' + VERSION + parser.add_argument('-v', '--version', action='version', + version=versionstr) + return parser + + +def _add_io_arguments(parser): + msg = "input file to be processed (default: '-', stdin)" + parser.add_argument('infile', nargs='?', default='-', help=msg) + msg = "output file where processed content will be written (default: " \ + "'-', stdout)" + parser.add_argument('outfile', nargs='?', default='-', help=msg) + + +def run_fypp(): + '''Run the Fypp command line tool.''' + options = FyppOptions() + argparser = get_option_parser() + _add_io_arguments(argparser) + args = argparser.parse_args(namespace=options) + try: + tool = Fypp(args) + tool.process_file(args.infile, args.outfile) + except FyppStopRequest as exc: + sys.stderr.write("STOP REQUEST in file '{}', line {}"\ + .format(exc.fname, exc.span[0] + 1)) + sys.stderr.write('\n') + sys.stderr.write(str(exc.msg)) + sys.stderr.write('\n') + sys.exit(USER_ERROR_EXIT_CODE) + except FyppFatalError as exc: + sys.stderr.write(str(exc)) + sys.stderr.write('\n') + sys.exit(ERROR_EXIT_CODE) + + +def _shiftinds(inds, shift): + return [ind + shift for ind in inds] + + +def _open_input_file(inpfile): + try: + inpfp = open(inpfile, 'r') + except IOError as exc: + msg = "Failed to open file '{}' for read".format(inpfile) + raise FyppFatalError(msg, cause=exc) + return inpfp + + +def _open_output_file(outfile, create_parents=False): + if create_parents: + parentdir = os.path.abspath(os.path.dirname(outfile)) + if not os.path.exists(parentdir): + try: + os.makedirs(parentdir) + except OSError as exc: + if exc.errno != errno.EEXIST: + msg = "Folder '{}' can not be created"\ + .format(parentdir) + raise FyppFatalError(msg, cause=exc) + try: + outfp = open(outfile, 'w') + except IOError as exc: + msg = "Failed to open file '{}' for write".format(outfile) + raise FyppFatalError(msg, cause=exc) + return outfp + + +if __name__ == '__main__': + run_fypp() diff --git a/make.arch.template b/make.arch.template index 229eca3..a6bcf26 100644 --- a/make.arch.template +++ b/make.arch.template @@ -14,8 +14,8 @@ LN = $(FXX) # Linker options LNOPT = -# M4 interpreter -M4 = m4 +# FYPP interpreter +FYPP = fypp -# M4 interpreter options (e.g. -DDEBUG for debug mode) -M4OPT = "" +# FYPP interpreter options (e.g. -DDEBUG for debug mode) +FYPPOPT = "" diff --git a/src/GNUmakefile b/src/GNUmakefile index 4affd8c..121722a 100644 --- a/src/GNUmakefile +++ b/src/GNUmakefile @@ -6,6 +6,8 @@ # ############################################################################ +ROOT = .. + include ../make.arch .PHONY: _FORCED_SUBMAKE_ @@ -13,7 +15,7 @@ _FORCED_SUBMAKE_: $(MAKE) \ FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="$(M4OPT)" \ + FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" \ -f Makefile.lib .PHONY: clean distclean diff --git a/src/Makefile.dep b/src/Makefile.dep index e3e42e5..f7c42f3 100644 --- a/src/Makefile.dep +++ b/src/Makefile.dep @@ -1,119 +1,74 @@ .SECONDEXPANSION: -mpifx_barrier.o: mpifx_barrier.m4 $$(_modobj_mpifx_common_module) -mpifx_barrier.o = mpifx_barrier.o $(mpifx_barrier.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_barrier_module = mpifx_barrier.o - -mpifx_init.m4: mpifx_common.m4 -mpifx_init.m4 = $(mpifx_common.m4) - -mpifx_abort.o: mpifx_abort.m4 $$(_modobj_mpifx_common_module) -mpifx_abort.o = mpifx_abort.o $(mpifx_abort.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_abort_module = mpifx_abort.o - -mpifx_constants.o: mpifx_constants.m4 $$(_modobj_mpi) -mpifx_constants.o = mpifx_constants.o $(mpifx_constants.m4) $($(_modobj_mpi)) -_modobj_mpifx_constants_module = mpifx_constants.o - -mpifx_allreduce.o: mpifx_allreduce.m4 $$(_modobj_mpifx_common_module) -mpifx_allreduce.o = mpifx_allreduce.o $(mpifx_allreduce.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allreduce_module = mpifx_allreduce.o - -mpifx_send.o: mpifx_send.m4 $$(_modobj_mpifx_common_module) -mpifx_send.o = mpifx_send.o $(mpifx_send.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_send_module = mpifx_send.o +mpifx_helper.o: $$(_modobj_mpi) +mpifx_helper.o = mpifx_helper.o $($(_modobj_mpi)) +_modobj_mpifx_helper_module = mpifx_helper.o -mpifx_get_processor_name.m4: mpifx_helper.m4 -mpifx_get_processor_name.m4 = $(mpifx_helper.m4) +mpifx_recv.o: $$(_modobj_mpifx_common_module) +mpifx_recv.o = mpifx_recv.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_recv_module = mpifx_recv.o -mpifx_reduce.m4: mpifx_common.m4 -mpifx_reduce.m4 = $(mpifx_common.m4) +mpifx_get_processor_name.o: $$(_modobj_mpifx_common) +mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpifx_common)) +_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o -mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 -mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) $(mpifx_gather.m4) +mpifx_gather.o: $$(_modobj_mpifx_common_module) +mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_gather_module = mpifx_gather.o -mpifx_comm.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_comm.m4 -mpifx_comm.o = mpifx_comm.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_comm.m4) -_modobj_mpifx_comm_module = mpifx_comm.o - -mpifx_scatter.o: $$(_modobj_mpifx_common_module) mpifx_scatter.m4 -mpifx_scatter.o = mpifx_scatter.o $($(_modobj_mpifx_common_module)) $(mpifx_scatter.m4) -_modobj_mpifx_scatter_module = mpifx_scatter.o - -mpifx_scatter.m4: mpifx_common.m4 -mpifx_scatter.m4 = $(mpifx_common.m4) - -mpifx_finalize.o: mpifx_finalize.m4 $$(_modobj_mpifx_common_module) -mpifx_finalize.o = mpifx_finalize.o $(mpifx_finalize.m4) $($(_modobj_mpifx_common_module)) +mpifx_finalize.o: $$(_modobj_mpifx_common_module) +mpifx_finalize.o = mpifx_finalize.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_finalize_module = mpifx_finalize.o -mpifx_barrier.m4: mpifx_common.m4 -mpifx_barrier.m4 = $(mpifx_common.m4) - -mpifx_recv.m4: mpifx_common.m4 -mpifx_recv.m4 = $(mpifx_common.m4) - -mpifx_helper.o: mpifx_helper.m4 $$(_modobj_mpi) -mpifx_helper.o = mpifx_helper.o $(mpifx_helper.m4) $($(_modobj_mpi)) -_modobj_mpifx_helper_module = mpifx_helper.o - -mpifx_gather.m4: mpifx_common.m4 -mpifx_gather.m4 = $(mpifx_common.m4) - -mpifx_finalize.m4: mpifx_common.m4 -mpifx_finalize.m4 = $(mpifx_common.m4) - -mpifx_get_processor_name.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_get_processor_name.m4 -mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_get_processor_name.m4) -_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o +mpifx_send.o: $$(_modobj_mpifx_common_module) +mpifx_send.o = mpifx_send.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_send_module = mpifx_send.o -mpifx_allgather.o: mpifx_allgather.m4 $$(_modobj_mpifx_common_module) -mpifx_allgather.o = mpifx_allgather.o $(mpifx_allgather.m4) $($(_modobj_mpifx_common_module)) +mpifx_allgather.o: $$(_modobj_mpifx_common_module) +mpifx_allgather.o = mpifx_allgather.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_allgather_module = mpifx_allgather.o -mpifx_init.o: mpifx_init.m4 $$(_modobj_mpifx_common_module) -mpifx_init.o = mpifx_init.o $(mpifx_init.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_init_module = mpifx_init.o +mpifx_constants.o: $$(_modobj_mpifx_common) +mpifx_constants.o = mpifx_constants.o $($(_modobj_mpifx_common)) +_modobj_mpifx_constants_module = mpifx_constants.o -mpifx_abort.m4: mpifx_common.m4 -mpifx_abort.m4 = $(mpifx_common.m4) +module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +_modobj_libmpifx_module = module.o -mpifx_bcast.o: $$(_modobj_mpifx_common_module) mpifx_bcast.m4 -mpifx_bcast.o = mpifx_bcast.o $($(_modobj_mpifx_common_module)) $(mpifx_bcast.m4) -_modobj_mpifx_bcast_module = mpifx_bcast.o +mpifx_allreduce.o: $$(_modobj_mpifx_common_module) +mpifx_allreduce.o = mpifx_allreduce.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_allreduce_module = mpifx_allreduce.o -mpifx_send.m4: mpifx_common.m4 -mpifx_send.m4 = $(mpifx_common.m4) +mpifx_init.o: $$(_modobj_mpifx_common_module) +mpifx_init.o = mpifx_init.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_init_module = mpifx_init.o -mpifx_common.o: $$(_modobj_mpi) mpifx_common.m4 $$(_modobj_mpifx_comm_module) $$(_modobj_mpifx_helper_module) -mpifx_common.o = mpifx_common.o $($(_modobj_mpi)) $(mpifx_common.m4) $($(_modobj_mpifx_comm_module)) $($(_modobj_mpifx_helper_module)) +mpifx_common.o: $$(_modobj_mpifx_helper_module) $$(_modobj_mpi) $$(_modobj_mpifx_comm_module) +mpifx_common.o = mpifx_common.o $($(_modobj_mpifx_helper_module)) $($(_modobj_mpi)) $($(_modobj_mpifx_comm_module)) _modobj_mpifx_common_module = mpifx_common.o -mpifx_common.m4: mpifx_helper.m4 -mpifx_common.m4 = $(mpifx_helper.m4) - -mpifx_bcast.m4: mpifx_common.m4 -mpifx_bcast.m4 = $(mpifx_common.m4) - -libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) -_modobj_libmpifx_module = libmpifx.o +mpifx_reduce.o: $$(_modobj_mpifx_common_module) +mpifx_reduce.o = mpifx_reduce.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_reduce_module = mpifx_reduce.o -mpifx_allreduce.m4: mpifx_common.m4 -mpifx_allreduce.m4 = $(mpifx_common.m4) +mpifx_barrier.o: $$(_modobj_mpifx_common_module) +mpifx_barrier.o = mpifx_barrier.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_barrier_module = mpifx_barrier.o -mpifx_reduce.o: mpifx_reduce.m4 $$(_modobj_mpifx_common_module) -mpifx_reduce.o = mpifx_reduce.o $(mpifx_reduce.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_reduce_module = mpifx_reduce.o +mpifx_comm.o: $$(_modobj_mpifx_helper_module) $$(_modobj_mpi) +mpifx_comm.o = mpifx_comm.o $($(_modobj_mpifx_helper_module)) $($(_modobj_mpi)) +_modobj_mpifx_comm_module = mpifx_comm.o -mpifx_recv.o: $$(_modobj_mpifx_common_module) mpifx_recv.m4 -mpifx_recv.o = mpifx_recv.o $($(_modobj_mpifx_common_module)) $(mpifx_recv.m4) -_modobj_mpifx_recv_module = mpifx_recv.o +mpifx_scatter.o: $$(_modobj_mpifx_common_module) +mpifx_scatter.o = mpifx_scatter.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_scatter_module = mpifx_scatter.o -mpifx_comm.m4: mpifx_helper.m4 -mpifx_comm.m4 = $(mpifx_helper.m4) +mpifx_abort.o: $$(_modobj_mpifx_common_module) +mpifx_abort.o = mpifx_abort.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_abort_module = mpifx_abort.o -mpifx_allgather.m4: mpifx_common.m4 -mpifx_allgather.m4 = $(mpifx_common.m4) +mpifx_bcast.o: $$(_modobj_mpifx_common_module) +mpifx_bcast.o = mpifx_bcast.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_bcast_module = mpifx_bcast.o diff --git a/src/Makefile.lib b/src/Makefile.lib index ad1478b..e74c763 100644 --- a/src/Makefile.lib +++ b/src/Makefile.lib @@ -5,15 +5,15 @@ # 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 +# FYPP: FYPP pre-processor +# FYPPOPT: Options for the FYPP pre-processor. You should use the -I option # with this directory, if you are invoking the makefile from somewhere # else. You may also use the -D option to define macros (e.g. DEBUG) # ############################################################################### .SUFFIXES: -.SUFFIXES: .f90 .F90 .o +.SUFFIXES: .f90 .fpp .o TARGETLIB = libmpifx.a @@ -22,11 +22,11 @@ all: $(TARGETLIB) include Makefile.dep -$(TARGETLIB): $(libmpifx.o) +$(TARGETLIB): $(module.o) ar r $@ $^ -%.f90: %.F90 - $(M4) $(M4OPT) $< > $@ +%.f90: %.fpp + $(FYPP) $(FYPPOPT) $< > $@ %.o: %.f90 $(FXX) $(FXXOPT) -c $< diff --git a/src/libmpifx.F90 b/src/module.fpp similarity index 81% rename from src/libmpifx.F90 rename to src/module.fpp index c5e0a4c..8c6cb62 100644 --- a/src/libmpifx.F90 +++ b/src/module.fpp @@ -1,14 +1,14 @@ !> \mainpage Modern Fortran wrappers around MPI routines !! -!! The open source library [MPIFX](https://www.bitbucket.org/aradi/mpifx) is +!! The open source library [MPIFX](https://www.bitbucket.org/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://aradi.bitbucket.org/mpifx/) +!! * [Online documentation](https://dftbplus.bitbucket.org/mpifx/) !! for installation and usage of the library !! * [API documentation](annotated.html) for the reference manual. -!! * [Project home page](https://www.bitbucket.org/aradi/mpifx/) +!! * [Project home page](https://www.bitbucket.org/dftbplus/mpifx/) !! for the source code, bug tracker and further information on the project. !! module libmpifx_module diff --git a/src/mpifx.fypp b/src/mpifx.fypp new file mode 100644 index 0000000..4377386 --- /dev/null +++ b/src/mpifx.fypp @@ -0,0 +1,72 @@ +#: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 ensure(cond) +#:call debug_code +if (.not. (${cond}$)) then + call ensure_failed("${_FILE_}$", ${_LINE_}$) +end if +#:endcall +#:enddef ensure + +#:endmute diff --git a/src/mpifx_abort.F90 b/src/mpifx_abort.fpp similarity index 86% rename from src/mpifx_abort.F90 rename to src/mpifx_abort.fpp index 2c4fd84..fe73917 100644 --- a/src/mpifx_abort.F90 +++ b/src/mpifx_abort.fpp @@ -1,5 +1,3 @@ -include(mpifx_abort.m4) - !> Contains wrapper for \c MPI_ABORT. module mpifx_abort_module use mpifx_common_module @@ -13,7 +11,7 @@ module mpifx_abort_module !> Aborts MPI processes for the given communicator. !! !! \param mycomm MPI handler. - !! \param errorcode Exit error code for the operating system. (default: -1) + !! \param errorcode Exit error code for the operating system. (default: 1) !! \param error Optional error flag. !! !! \see MPI documentation (\c MPI_ABORT) @@ -41,9 +39,15 @@ subroutine mpifx_abort(mycomm, errorcode, error) integer :: error0, errorcode0 - _handle_inoptflag(errorcode0, errorcode, -1) + 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) + if (present(error)) then + error = error0 + end if end subroutine mpifx_abort diff --git a/src/mpifx_abort.m4 b/src/mpifx_abort.m4 deleted file mode 100644 index 40a7479..0000000 --- a/src/mpifx_abort.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_common.m4) diff --git a/src/mpifx_allgather.F90 b/src/mpifx_allgather.F90 deleted file mode 100644 index 4df5301..0000000 --- a/src/mpifx_allgather.F90 +++ /dev/null @@ -1,248 +0,0 @@ -include(mpifx_allgather.m4) - -!> 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. - !! - !! \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 that case - !! the last dimension of it must be of the size of the number of processes - !! in the gathering. - !! - !! \see MPI documentation (\c MPI_ALLGATHER) - !! - !! 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 - module procedure & - & mpifx_allgather_i1i1, mpifx_allgather_i2i2, mpifx_allgather_i3i3, & - & mpifx_allgather_i4i4, mpifx_allgather_i5i5, mpifx_allgather_i6i6 - module procedure & - & mpifx_allgather_i0i1, mpifx_allgather_i1i2, mpifx_allgather_i2i3, & - & mpifx_allgather_i3i4, mpifx_allgather_i4i5, mpifx_allgather_i5i6 - module procedure & - & mpifx_allgather_s1s1, mpifx_allgather_s2s2, mpifx_allgather_s3s3, & - & mpifx_allgather_s4s4, mpifx_allgather_s5s5, mpifx_allgather_s6s6 - module procedure & - & mpifx_allgather_s0s1, mpifx_allgather_s1s2, mpifx_allgather_s2s3, & - & mpifx_allgather_s3s4, mpifx_allgather_s4s5, mpifx_allgather_s5s6 - module procedure & - & mpifx_allgather_d1d1, mpifx_allgather_d2d2, mpifx_allgather_d3d3, & - & mpifx_allgather_d4d4, mpifx_allgather_d5d5, mpifx_allgather_d6d6 - module procedure & - & mpifx_allgather_d0d1, mpifx_allgather_d1d2, mpifx_allgather_d2d3, & - & mpifx_allgather_d3d4, mpifx_allgather_d4d5, mpifx_allgather_d5d6 - module procedure & - & mpifx_allgather_c1c1, mpifx_allgather_c2c2, mpifx_allgather_c3c3, & - & mpifx_allgather_c4c4, mpifx_allgather_c5c5, mpifx_allgather_c6c6 - module procedure & - & mpifx_allgather_c0c1, mpifx_allgather_c1c2, mpifx_allgather_c2c3, & - & mpifx_allgather_c3c4, mpifx_allgather_c4c5, mpifx_allgather_c5c6 - module procedure & - & mpifx_allgather_z1z1, mpifx_allgather_z2z2, mpifx_allgather_z3z3, & - & mpifx_allgather_z4z4, mpifx_allgather_z5z5, mpifx_allgather_z6z6 - module procedure & - & mpifx_allgather_z0z1, mpifx_allgather_z1z2, mpifx_allgather_z2z3, & - & mpifx_allgather_z3z4, mpifx_allgather_z4z5, mpifx_allgather_z5z6 - module procedure & - & mpifx_allgather_l1l1, mpifx_allgather_l2l2, mpifx_allgather_l3l3, & - & mpifx_allgather_l4l4, mpifx_allgather_l5l5, mpifx_allgather_l6l6 - module procedure & - & mpifx_allgather_l0l1, mpifx_allgather_l1l2, mpifx_allgather_l2l3, & - & mpifx_allgather_l3l4, mpifx_allgather_l4l5, mpifx_allgather_l5l6 - end interface mpifx_allgather - - -contains - - _subroutine_mpifx_allgather_dr0(i1i1, integer, (:), 1, MPI_INTEGER) - _subroutine_mpifx_allgather_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) - _subroutine_mpifx_allgather_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - _subroutine_mpifx_allgather_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - _subroutine_mpifx_allgather_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_allgather_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - _subroutine_mpifx_allgather_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) - _subroutine_mpifx_allgather_dr1(i1i2, integer, (:), size(send), (:,:), 2, - MPI_INTEGER) - _subroutine_mpifx_allgather_dr1(i2i3, integer, (:,:), size(send), (:,:,:), 3, - MPI_INTEGER) - _subroutine_mpifx_allgather_dr1(i3i4, integer, (:,:,:), size(send), (:,:,:,:), - 4, MPI_INTEGER) - _subroutine_mpifx_allgather_dr1(i4i5, integer, (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_allgather_dr1(i5i6, integer, (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_INTEGER) - - - _subroutine_mpifx_allgather_dr0(s1s1, real(sp), (:), 1, MPI_REAL) - _subroutine_mpifx_allgather_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) - _subroutine_mpifx_allgather_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - _subroutine_mpifx_allgather_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - _subroutine_mpifx_allgather_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_allgather_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - _subroutine_mpifx_allgather_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) - _subroutine_mpifx_allgather_dr1(s1s2, real(sp), (:), size(send), (:,:), 2, - MPI_REAL) - _subroutine_mpifx_allgather_dr1(s2s3, real(sp), (:,:), size(send), (:,:,:), - 3, MPI_REAL) - _subroutine_mpifx_allgather_dr1(s3s4, real(sp), (:,:,:), size(send), - (:,:,:,:), 4, MPI_REAL) - _subroutine_mpifx_allgather_dr1(s4s5, real(sp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_allgather_dr1(s5s6, real(sp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_REAL) - - - _subroutine_mpifx_allgather_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr0(d2d2, real(dp), (:,:), 2, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr0(d3d3, real(dp), (:,:,:), 3, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr0(d4d4, real(dp), (:,:,:,:), 4, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr0(d5d5, real(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_allgather_dr1(d0d1, real(dp), , 1, (:), 1, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr1(d1d2, real(dp), (:), size(send), (:,:), 2, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr1(d2d3, real(dp), (:,:), size(send), (:,:,:), - 3, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr1(d3d4, real(dp), (:,:,:), size(send), - (:,:,:,:), 4, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr1(d4d5, real(dp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgather_dr1(d5d6, real(dp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) - - - _subroutine_mpifx_allgather_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, - MPI_COMPLEX) - _subroutine_mpifx_allgather_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, - MPI_COMPLEX) - - _subroutine_mpifx_allgather_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr1(c1c2, complex(sp), (:), size(send), (:,:), 2, - MPI_COMPLEX) - _subroutine_mpifx_allgather_dr1(c2c3, complex(sp), (:,:), size(send), - (:,:,:), 3, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr1(c3c4, complex(sp), (:,:,:), size(send), - (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr1(c4c5, complex(sp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_allgather_dr1(c5c6, complex(sp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - _subroutine_mpifx_allgather_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr0(z2z2, complex(dp), (:,:), 2, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr0(z3z3, complex(dp), (:,:,:), 3, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr0(z4z4, complex(dp), (:,:,:,:), 4, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_allgather_dr1(z0z1, complex(dp), , 1, (:), 1, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr1(z1z2, complex(dp), (:), size(send), (:,:), 2, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr1(z2z3, complex(dp), (:,:), size(send), (:,:,:), - 3, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr1(z3z4, complex(dp), (:,:,:), size(send), - (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr1(z4z5, complex(dp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgather_dr1(z5z6, complex(dp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) - - - _subroutine_mpifx_allgather_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - _subroutine_mpifx_allgather_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr1(l1l2, logical, (:), size(send), (:,:), 2, - MPI_LOGICAL) - _subroutine_mpifx_allgather_dr1(l2l3, logical, (:,:), size(send), (:,:,:), 3, - MPI_LOGICAL) - _subroutine_mpifx_allgather_dr1(l3l4, logical, (:,:,:), size(send), (:,:,:,:), - 4, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr1(l4l5, logical, (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_allgather_dr1(l5l6, logical, (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_LOGICAL) - - -end module mpifx_allgather_module diff --git a/src/mpifx_allgather.fpp b/src/mpifx_allgather.fpp new file mode 100644 index 0000000..159590a --- /dev/null +++ b/src/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) + + @:ensure (size(recv) == ${SIZE}$ * mycomm%size) + @:ensure (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) + + @:ensure (size(recv) == ${SIZE}$ * mycomm%size) + @:ensure (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/src/mpifx_allgather.m4 b/src/mpifx_allgather.m4 deleted file mode 100644 index 2dd0771..0000000 --- a/src/mpifx_allgather.m4 +++ /dev/null @@ -1,75 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_allgather -dnl ************************************************************************ - -define(`_subroutine_mpifx_allgather_dr0',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send/recv buffer rank (1, 2, etc.) -dnl $5: corresponding MPI type -dnl -!> Gathers results on all processes (type $1). -!! -!! \param mycomm MPI communicator. -!! \param send Quantity to be sent for gathering. -!! \param recv Received data. -!! \param error Error code on exit. -!! -subroutine mpifx_allgather_$1(mycomm, send, recv, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$3 - integer, intent(out), optional :: error - - integer :: error0 - - _assert(size(recv) == size(send) * mycomm%size) - _assert(size(recv, dim=$4) == size(send, dim=$4) * mycomm%size) - - call mpi_allgather(send, size(send), $5, recv, size(send), & - & $5, mycomm%id, error0) - call handle_errorflag(error0, "MPI_ALLGATHER in mpifx_allgather_$1", error) - -end subroutine mpifx_allgather_$1 -') - - -define(`_subroutine_mpifx_allgather_dr1',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send buffer size (1 or size(send)) -dnl $5: recv buffer rank specifier ((:), (:,:), etc.) -dnl $6: recv buffers rank (1, 2, etc.) -dnl $7: corresponding MPI type -dnl -!> Gathers results on all processes (type $1). -!! -!! \param mycomm MPI communicator. -!! \param send Quantity to be sent for gathering. -!! \param recv Received data. -!! \param error Error code on exit. -!! -subroutine mpifx_allgather_$1(mycomm, send, recv, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$5 - integer, intent(out), optional :: error - - integer :: error0 - - _assert(size(recv) == $4 * mycomm%size) - _assert(size(recv, dim=$6) == mycomm%size) - - call mpi_allgather(send, $4, $7, recv, $4, & - & $7, mycomm%id, error0) - call handle_errorflag(error0, "MPI_ALLGATHER in mpifx_allgather_$1", error) - -end subroutine mpifx_allgather_$1 - -') diff --git a/src/mpifx_allreduce.F90 b/src/mpifx_allreduce.F90 deleted file mode 100644 index 8e04143..0000000 --- a/src/mpifx_allreduce.F90 +++ /dev/null @@ -1,290 +0,0 @@ -include(mpifx_allreduce.m4) - -!> 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 - module procedure & - & mpifx_allreduce_i0, mpifx_allreduce_i1, mpifx_allreduce_i2, & - & mpifx_allreduce_i3, mpifx_allreduce_i4, mpifx_allreduce_i5, & - & mpifx_allreduce_i6 - module procedure & - & mpifx_allreduce_s0, mpifx_allreduce_s1, mpifx_allreduce_s2, & - & mpifx_allreduce_s3, mpifx_allreduce_s4, mpifx_allreduce_s5, & - & mpifx_allreduce_s6 - module procedure & - & mpifx_allreduce_d0, mpifx_allreduce_d1, mpifx_allreduce_d2, & - & mpifx_allreduce_d3, mpifx_allreduce_d4, mpifx_allreduce_d5, & - & mpifx_allreduce_d6 - module procedure & - & mpifx_allreduce_c0, mpifx_allreduce_c1, mpifx_allreduce_c2, & - & mpifx_allreduce_c3, mpifx_allreduce_c4, mpifx_allreduce_c5, & - & mpifx_allreduce_c6 - module procedure & - & mpifx_allreduce_z0, mpifx_allreduce_z1, mpifx_allreduce_z2, & - & mpifx_allreduce_z3, mpifx_allreduce_z4, mpifx_allreduce_z5, & - & mpifx_allreduce_z6 - module procedure & - & mpifx_allreduce_l0, mpifx_allreduce_l1, mpifx_allreduce_l2, & - & mpifx_allreduce_l3, mpifx_allreduce_l4, mpifx_allreduce_l5, & - & mpifx_allreduce_l6 - 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 - module procedure & - & mpifx_allreduceip_i0, mpifx_allreduceip_i1, mpifx_allreduceip_i2, & - & mpifx_allreduceip_i3, mpifx_allreduceip_i4, mpifx_allreduceip_i5, & - & mpifx_allreduceip_i6 - module procedure & - & mpifx_allreduceip_s0, mpifx_allreduceip_s1, mpifx_allreduceip_s2, & - & mpifx_allreduceip_s3, mpifx_allreduceip_s4, mpifx_allreduceip_s5, & - & mpifx_allreduceip_s6 - module procedure & - & mpifx_allreduceip_d0, mpifx_allreduceip_d1, mpifx_allreduceip_d2, & - & mpifx_allreduceip_d3, mpifx_allreduceip_d4, mpifx_allreduceip_d5, & - & mpifx_allreduceip_d6 - module procedure & - & mpifx_allreduceip_c0, mpifx_allreduceip_c1, mpifx_allreduceip_c2, & - & mpifx_allreduceip_c3, mpifx_allreduceip_c4, mpifx_allreduceip_c5, & - & mpifx_allreduceip_c6 - module procedure & - & mpifx_allreduceip_z0, mpifx_allreduceip_z1, mpifx_allreduceip_z2, & - & mpifx_allreduceip_z3, mpifx_allreduceip_z4, mpifx_allreduceip_z5, & - & mpifx_allreduceip_z6 - module procedure & - & mpifx_allreduceip_l0, mpifx_allreduceip_l1, mpifx_allreduceip_l2, & - & mpifx_allreduceip_l3, mpifx_allreduceip_l4, mpifx_allreduceip_l5, & - & mpifx_allreduceip_l6 - end interface mpifx_allreduceip - -contains - - _subroutine_mpifx_allreduce(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_allreduce(i1, integer, (:), size(operand), MPI_INTEGER) - _subroutine_mpifx_allreduce(i2, integer, (:,:), size(operand), MPI_INTEGER) - _subroutine_mpifx_allreduce(i3, integer, (:,:,:), size(operand), MPI_INTEGER) - _subroutine_mpifx_allreduce(i4, integer, (:,:,:,:), size(operand), - MPI_INTEGER) - _subroutine_mpifx_allreduce(i5, integer, (:,:,:,:,:), size(operand), - MPI_INTEGER) - _subroutine_mpifx_allreduce(i6, integer, (:,:,:,:,:,:), size(operand), - MPI_INTEGER) - - _subroutine_mpifx_allreduce(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_allreduce(s1, real(sp), (:), size(operand), MPI_REAL) - _subroutine_mpifx_allreduce(s2, real(sp), (:,:), size(operand), MPI_REAL) - _subroutine_mpifx_allreduce(s3, real(sp), (:,:,:), size(operand), MPI_REAL) - _subroutine_mpifx_allreduce(s4, real(sp), (:,:,:,:), size(operand), MPI_REAL) - _subroutine_mpifx_allreduce(s5, real(sp), (:,:,:,:,:), size(operand), - MPI_REAL) - _subroutine_mpifx_allreduce(s6, real(sp), (:,:,:,:,:,:), size(operand), - MPI_REAL) - - _subroutine_mpifx_allreduce(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduce(d1, real(dp), (:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduce(d2, real(dp), (:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduce(d3, real(dp), (:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduce(d4, real(dp), (:,:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduce(d5, real(dp), (:,:,:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduce(d6, real(dp), (:,:,:,:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_allreduce(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_allreduce(c1, complex(sp), (:), size(operand), MPI_COMPLEX) - _subroutine_mpifx_allreduce(c2, complex(sp), (:,:), size(operand), - MPI_COMPLEX) - _subroutine_mpifx_allreduce(c3, complex(sp), (:,:,:), size(operand), - MPI_COMPLEX) - _subroutine_mpifx_allreduce(c4, complex(sp), (:,:,:,:), size(operand), - MPI_COMPLEX) - _subroutine_mpifx_allreduce(c5, complex(sp), (:,:,:,:,:), size(operand), - MPI_COMPLEX) - _subroutine_mpifx_allreduce(c6, complex(sp), (:,:,:,:,:,:), size(operand), - MPI_COMPLEX) - - _subroutine_mpifx_allreduce(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduce(z1, complex(dp), (:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduce(z2, complex(dp), (:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduce(z3, complex(dp), (:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduce(z4, complex(dp), (:,:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduce(z5, complex(dp), (:,:,:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduce(z6, complex(dp), (:,:,:,:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_allreduce(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_allreduce(l1, logical, (:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_allreduce(l2, logical, (:,:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_allreduce(l3, logical, (:,:,:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_allreduce(l4, logical, (:,:,:,:), size(operand), - MPI_LOGICAL) - _subroutine_mpifx_allreduce(l5, logical, (:,:,:,:,:), size(operand), - MPI_LOGICAL) - _subroutine_mpifx_allreduce(l6, logical, (:,:,:,:,:,:), size(operand), - MPI_LOGICAL) - - _subroutine_mpifx_allreduceip(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_allreduceip(i1, integer, (:), size(opres), MPI_INTEGER) - _subroutine_mpifx_allreduceip(i2, integer, (:,:), size(opres), MPI_INTEGER) - _subroutine_mpifx_allreduceip(i3, integer, (:,:,:), size(opres), - MPI_INTEGER) - _subroutine_mpifx_allreduceip(i4, integer, (:,:,:,:), size(opres), - MPI_INTEGER) - _subroutine_mpifx_allreduceip(i5, integer, (:,:,:,:,:), size(opres), - MPI_INTEGER) - _subroutine_mpifx_allreduceip(i6, integer, (:,:,:,:,:,:), size(opres), - MPI_INTEGER) - - _subroutine_mpifx_allreduceip(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_allreduceip(s1, real(sp), (:), size(opres), MPI_REAL) - _subroutine_mpifx_allreduceip(s2, real(sp), (:,:), size(opres), MPI_REAL) - _subroutine_mpifx_allreduceip(s3, real(sp), (:,:,:), size(opres), MPI_REAL) - _subroutine_mpifx_allreduceip(s4, real(sp), (:,:,:,:), size(opres), - MPI_REAL) - _subroutine_mpifx_allreduceip(s5, real(sp), (:,:,:,:,:), size(opres), - MPI_REAL) - _subroutine_mpifx_allreduceip(s6, real(sp), (:,:,:,:,:,:), size(opres), - MPI_REAL) - - _subroutine_mpifx_allreduceip(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduceip(d1, real(dp), (:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduceip(d2, real(dp), (:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduceip(d3, real(dp), (:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduceip(d4, real(dp), (:,:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduceip(d5, real(dp), (:,:,:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allreduceip(d6, real(dp), (:,:,:,:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_allreduceip(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_allreduceip(c1, complex(sp), (:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_allreduceip(c2, complex(sp), (:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_allreduceip(c3, complex(sp), (:,:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_allreduceip(c4, complex(sp), (:,:,:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_allreduceip(c5, complex(sp), (:,:,:,:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_allreduceip(c6, complex(sp), (:,:,:,:,:,:), size(opres), - MPI_COMPLEX) - - _subroutine_mpifx_allreduceip(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduceip(z1, complex(dp), (:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduceip(z2, complex(dp), (:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduceip(z3, complex(dp), (:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduceip(z4, complex(dp), (:,:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduceip(z5, complex(dp), (:,:,:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allreduceip(z6, complex(dp), (:,:,:,:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_allreduceip(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_allreduceip(l1, logical, (:), size(opres), MPI_LOGICAL) - _subroutine_mpifx_allreduceip(l2, logical, (:,:), size(opres), MPI_LOGICAL) - _subroutine_mpifx_allreduceip(l3, logical, (:,:,:), size(opres), - MPI_LOGICAL) - _subroutine_mpifx_allreduceip(l4, logical, (:,:,:,:), size(opres), - MPI_LOGICAL) - _subroutine_mpifx_allreduceip(l5, logical, (:,:,:,:,:), size(opres), - MPI_LOGICAL) - _subroutine_mpifx_allreduceip(l6, logical, (:,:,:,:,:,:), size(opres), - MPI_LOGICAL) - - -end module mpifx_allreduce_module diff --git a/src/mpifx_allreduce.fpp b/src/mpifx_allreduce.fpp new file mode 100644 index 0000000..847486e --- /dev/null +++ b/src/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 + @:ensure (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/src/mpifx_allreduce.m4 b/src/mpifx_allreduce.m4 deleted file mode 100644 index 5d00915..0000000 --- a/src/mpifx_allreduce.m4 +++ /dev/null @@ -1,65 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_allreduce -dnl ************************************************************************ - -define(`_subroutine_mpifx_allreduce',`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 -!> Reduces results on all processes (type $1). -!! -!! \param mycomm MPI communicator. -!! \param operand Quantity to be reduced. -!! \param result Contains result on exit. -!! \param operator Reduction operator -!! \param error Error code on exit. -!! -subroutine mpifx_allreduce_$1(mycomm, operand, result, operator, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: operand$3 - $2, intent(inout) :: result$3 - integer, intent(in) :: operator - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_allreduce(operand, result, $4, $5, operator, mycomm%id, error0) - call handle_errorflag(error0, "MPI_ALLREDUCE in mpifx_allreduce_$1", error) - -end subroutine mpifx_allreduce_$1 -') - -dnl ************************************************************************ -dnl *** mpifx_allreduceip -dnl ************************************************************************ - -define(`_subroutine_mpifx_allreduceip',`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 -!> Reduces results on one process (type $1). -!! -!! \param mycomm MPI communicator. -!! \param opres Quantity to be reduced on input, result on exit -!! \param operator Reduction operator -!! \param error Error code on exit. -!! -subroutine mpifx_allreduceip_$1(mycomm, opres, operator, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(inout) :: opres$3 - integer, intent(in) :: operator - integer, intent(out), optional :: error - - integer :: error0 - - call mpi_allreduce(MPI_IN_PLACE, opres, $4, $5, operator, mycomm%id, error0) - call handle_errorflag(error0, "MPI_REDUCE in mpifx_allreduceip_$1", error) - -end subroutine mpifx_allreduceip_$1 -') diff --git a/src/mpifx_barrier.F90 b/src/mpifx_barrier.fpp similarity index 97% rename from src/mpifx_barrier.F90 rename to src/mpifx_barrier.fpp index c444013..cf8efde 100644 --- a/src/mpifx_barrier.F90 +++ b/src/mpifx_barrier.fpp @@ -1,4 +1,4 @@ -include(mpifx_barrier.m4) +#:include 'mpifx.fypp' !> Contains wrapper for \c MPI_BARRIER. module mpifx_barrier_module diff --git a/src/mpifx_barrier.m4 b/src/mpifx_barrier.m4 deleted file mode 100644 index 40a7479..0000000 --- a/src/mpifx_barrier.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_common.m4) diff --git a/src/mpifx_bcast.F90 b/src/mpifx_bcast.F90 deleted file mode 100644 index 39f1ee6..0000000 --- a/src/mpifx_bcast.F90 +++ /dev/null @@ -1,133 +0,0 @@ -include(mpifx_bcast.m4) - -!> 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 (i), real (s), double precision (d), complex (c), - !! double complex (z), logical (l) and character (h). 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%master) 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 - 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.fpp b/src/mpifx_bcast.fpp new file mode 100644 index 0000000..489e7cb --- /dev/null +++ b/src/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%master) 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%masterrank). + 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%masterrank, 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/src/mpifx_bcast.m4 b/src/mpifx_bcast.m4 deleted file mode 100644 index 3dc599d..0000000 --- a/src/mpifx_bcast.m4 +++ /dev/null @@ -1,33 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_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 mycomm MPI descriptor -!! \param msg Msg to be broadcasted on root and received on non-root -!! nodes. -!! \param root Root node for the broadcast (default: mycomm%masterrank). -!! \param error Optional error handling flag. -!! -subroutine mpifx_bcast_$1(mycomm, msg, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2 :: msg$3 - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _handle_inoptflag(root0, root, mycomm%masterrank) - call mpi_bcast(msg, $4, $5, root0, mycomm%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.fpp similarity index 97% rename from src/mpifx_comm.F90 rename to src/mpifx_comm.fpp index bc3d701..fcf6306 100644 --- a/src/mpifx_comm.F90 +++ b/src/mpifx_comm.fpp @@ -1,9 +1,7 @@ -include(mpifx_comm.m4) - !> Contains the extended MPI communicator. module mpifx_comm_module - use mpifx_helper_module use mpi + use mpifx_helper_module implicit none private @@ -41,7 +39,7 @@ subroutine mpifx_comm_init(self, commid, error) integer :: error0 - _handle_inoptflag(self%id, commid, MPI_COMM_WORLD) + 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 @@ -57,6 +55,7 @@ subroutine mpifx_comm_init(self, commid, error) end subroutine mpifx_comm_init + !> Creates a new communicators by splitting the old one. !! !! \param self Communicator instance. @@ -100,8 +99,7 @@ subroutine mpifx_comm_split(self, splitkey, rankkey, newcomm, 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) + call handle_errorflag(error0, "mpi_comm_split() in mpifx_comm_split()", error) if (error0 /= 0) then return end if diff --git a/src/mpifx_comm.m4 b/src/mpifx_comm.m4 deleted file mode 100644 index 3b8c873..0000000 --- a/src/mpifx_comm.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_helper.m4) diff --git a/src/mpifx_common.F90 b/src/mpifx_common.fpp similarity index 84% rename from src/mpifx_common.F90 rename to src/mpifx_common.fpp index 8dd2333..eba5d03 100644 --- a/src/mpifx_common.F90 +++ b/src/mpifx_common.fpp @@ -1,6 +1,4 @@ -include(mpifx_common.m4) - -!> Exports constants, helper functions, MPI descriptor and legace MPI routines. +!> Exports constants, helper functions, MPI descriptor and legacy MPI routines. !! \cond HIDDEN module mpifx_common_module use mpi diff --git a/src/mpifx_common.m4 b/src/mpifx_common.m4 deleted file mode 100644 index 3b8c873..0000000 --- a/src/mpifx_common.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_helper.m4) diff --git a/src/mpifx_constants.F90 b/src/mpifx_constants.fpp similarity index 88% rename from src/mpifx_constants.F90 rename to src/mpifx_constants.fpp index 3b9c723..f2ba3f4 100644 --- a/src/mpifx_constants.F90 +++ b/src/mpifx_constants.fpp @@ -1,9 +1,7 @@ -include(mpifx_constants.m4) - !> Exports some MPI constants. !! \cond HIDDEN module mpifx_constants_module - use mpi + use mpifx_common_module private public :: MPI_MAX, MPI_MIN, MPI_SUM, MPI_PROD diff --git a/src/mpifx_constants.m4 b/src/mpifx_constants.m4 deleted file mode 100644 index e69de29..0000000 diff --git a/src/mpifx_finalize.F90 b/src/mpifx_finalize.fpp similarity index 93% rename from src/mpifx_finalize.F90 rename to src/mpifx_finalize.fpp index 5415b58..b9b98cc 100644 --- a/src/mpifx_finalize.F90 +++ b/src/mpifx_finalize.fpp @@ -1,5 +1,3 @@ -include(mpifx_finalize.m4) - !> Contains wrapper for \c MPI_FINALIZE. module mpifx_finalize_module use mpifx_common_module @@ -38,8 +36,7 @@ subroutine mpifx_finalize(error) integer :: error0 call mpi_finalize(error0) - call handle_errorflag(error0, "Error: mpi_finalize() in mpifx_finalize()", & - & error) + call handle_errorflag(error0, "Error: mpi_finalize() in mpifx_finalize()", error) end subroutine mpifx_finalize diff --git a/src/mpifx_finalize.m4 b/src/mpifx_finalize.m4 deleted file mode 100644 index 40a7479..0000000 --- a/src/mpifx_finalize.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_common.m4) diff --git a/src/mpifx_gather.F90 b/src/mpifx_gather.F90 deleted file mode 100644 index 168fa2d..0000000 --- a/src/mpifx_gather.F90 +++ /dev/null @@ -1,259 +0,0 @@ -include(mpifx_gather.m4) - -!> 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%master) 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%master) 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%master) 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%master) then - !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 - !! end if - !! - !! ! I1 -> I2 - !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] - !! if (mycomm%master) 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%master) then - !! write(*, *) mycomm%rank, "Recv2 buffer:", recv2 - !! end if - !! - !! call mpifx_finalize() - !! - !! end program test_gather - !! - interface mpifx_gather - module procedure & - & mpifx_gather_i1i1, mpifx_gather_i2i2, mpifx_gather_i3i3, & - & mpifx_gather_i4i4, mpifx_gather_i5i5, mpifx_gather_i6i6 - module procedure & - & mpifx_gather_i0i1, mpifx_gather_i1i2, mpifx_gather_i2i3, & - & mpifx_gather_i3i4, mpifx_gather_i4i5, mpifx_gather_i5i6 - module procedure & - & mpifx_gather_s1s1, mpifx_gather_s2s2, mpifx_gather_s3s3, & - & mpifx_gather_s4s4, mpifx_gather_s5s5, mpifx_gather_s6s6 - module procedure & - & mpifx_gather_s0s1, mpifx_gather_s1s2, mpifx_gather_s2s3, & - & mpifx_gather_s3s4, mpifx_gather_s4s5, mpifx_gather_s5s6 - module procedure & - & mpifx_gather_d1d1, mpifx_gather_d2d2, mpifx_gather_d3d3, & - & mpifx_gather_d4d4, mpifx_gather_d5d5, mpifx_gather_d6d6 - module procedure & - & mpifx_gather_d0d1, mpifx_gather_d1d2, mpifx_gather_d2d3, & - & mpifx_gather_d3d4, mpifx_gather_d4d5, mpifx_gather_d5d6 - module procedure & - & mpifx_gather_c1c1, mpifx_gather_c2c2, mpifx_gather_c3c3, & - & mpifx_gather_c4c4, mpifx_gather_c5c5, mpifx_gather_c6c6 - module procedure & - & mpifx_gather_c0c1, mpifx_gather_c1c2, mpifx_gather_c2c3, & - & mpifx_gather_c3c4, mpifx_gather_c4c5, mpifx_gather_c5c6 - module procedure & - & mpifx_gather_z1z1, mpifx_gather_z2z2, mpifx_gather_z3z3, & - & mpifx_gather_z4z4, mpifx_gather_z5z5, mpifx_gather_z6z6 - module procedure & - & mpifx_gather_z0z1, mpifx_gather_z1z2, mpifx_gather_z2z3, & - & mpifx_gather_z3z4, mpifx_gather_z4z5, mpifx_gather_z5z6 - module procedure & - & mpifx_gather_l1l1, mpifx_gather_l2l2, mpifx_gather_l3l3, & - & mpifx_gather_l4l4, mpifx_gather_l5l5, mpifx_gather_l6l6 - module procedure & - & mpifx_gather_l0l1, mpifx_gather_l1l2, mpifx_gather_l2l3, & - & mpifx_gather_l3l4, mpifx_gather_l4l5, mpifx_gather_l5l6 - end interface mpifx_gather - - -contains - - _subroutine_mpifx_gather_dr0(i1i1, integer, (:), 1, MPI_INTEGER) - _subroutine_mpifx_gather_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) - _subroutine_mpifx_gather_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - _subroutine_mpifx_gather_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - _subroutine_mpifx_gather_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_gather_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - _subroutine_mpifx_gather_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) - _subroutine_mpifx_gather_dr1(i1i2, integer, (:), size(send), (:,:), 2, - MPI_INTEGER) - _subroutine_mpifx_gather_dr1(i2i3, integer, (:,:), size(send), (:,:,:), 3, - MPI_INTEGER) - _subroutine_mpifx_gather_dr1(i3i4, integer, (:,:,:), size(send), (:,:,:,:), - 4, MPI_INTEGER) - _subroutine_mpifx_gather_dr1(i4i5, integer, (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_gather_dr1(i5i6, integer, (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_INTEGER) - - - _subroutine_mpifx_gather_dr0(s1s1, real(sp), (:), 1, MPI_REAL) - _subroutine_mpifx_gather_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) - _subroutine_mpifx_gather_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - _subroutine_mpifx_gather_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - _subroutine_mpifx_gather_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_gather_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - _subroutine_mpifx_gather_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) - _subroutine_mpifx_gather_dr1(s1s2, real(sp), (:), size(send), (:,:), 2, - MPI_REAL) - _subroutine_mpifx_gather_dr1(s2s3, real(sp), (:,:), size(send), (:,:,:), 3, - MPI_REAL) - _subroutine_mpifx_gather_dr1(s3s4, real(sp), (:,:,:), size(send), (:,:,:,:), - 4, MPI_REAL) - _subroutine_mpifx_gather_dr1(s4s5, real(sp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_gather_dr1(s5s6, real(sp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_REAL) - - - _subroutine_mpifx_gather_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr0(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr0(d4d4, real(dp), (:,:,:,:), 4, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr0(d5d5, real(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_gather_dr1(d0d1, real(dp), , 1, (:), 1, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr1(d1d2, real(dp), (:), size(send), (:,:), 2, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr1(d2d3, real(dp), (:,:), size(send), (:,:,:), 3, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr1(d3d4, real(dp), (:,:,:), size(send), (:,:,:,:), - 4, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr1(d4d5, real(dp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gather_dr1(d5d6, real(dp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) - - - _subroutine_mpifx_gather_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - _subroutine_mpifx_gather_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - _subroutine_mpifx_gather_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - _subroutine_mpifx_gather_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_gather_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_gather_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) - - _subroutine_mpifx_gather_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) - _subroutine_mpifx_gather_dr1(c1c2, complex(sp), (:), size(send), (:,:), 2, - MPI_COMPLEX) - _subroutine_mpifx_gather_dr1(c2c3, complex(sp), (:,:), size(send), (:,:,:), - 3, MPI_COMPLEX) - _subroutine_mpifx_gather_dr1(c3c4, complex(sp), (:,:,:), size(send), - (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_gather_dr1(c4c5, complex(sp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_gather_dr1(c5c6, complex(sp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - _subroutine_mpifx_gather_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr0(z3z3, complex(dp), (:,:,:), 3, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr0(z4z4, complex(dp), (:,:,:,:), 4, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_gather_dr1(z0z1, complex(dp), , 1, (:), 1, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr1(z1z2, complex(dp), (:), size(send), (:,:), 2, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr1(z2z3, complex(dp), (:,:), size(send), (:,:,:), - 3, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr1(z3z4, complex(dp), (:,:,:), size(send), - (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr1(z4z5, complex(dp), (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gather_dr1(z5z6, complex(dp), (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) - - - _subroutine_mpifx_gather_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_gather_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) - _subroutine_mpifx_gather_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - _subroutine_mpifx_gather_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - _subroutine_mpifx_gather_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_gather_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - _subroutine_mpifx_gather_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_gather_dr1(l1l2, logical, (:), size(send), (:,:), 2, - MPI_LOGICAL) - _subroutine_mpifx_gather_dr1(l2l3, logical, (:,:), size(send), (:,:,:), 3, - MPI_LOGICAL) - _subroutine_mpifx_gather_dr1(l3l4, logical, (:,:,:), size(send), (:,:,:,:), - 4, MPI_LOGICAL) - _subroutine_mpifx_gather_dr1(l4l5, logical, (:,:,:,:), size(send), - (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_gather_dr1(l5l6, logical, (:,:,:,:,:), size(send), - (:,:,:,:,:,:), 6, MPI_LOGICAL) - - -end module mpifx_gather_module diff --git a/src/mpifx_gather.fpp b/src/mpifx_gather.fpp new file mode 100644 index 0000000..f3e037e --- /dev/null +++ b/src/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%master) 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%master) 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%master) 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%master) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! ! I1 -> I2 + !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + !! if (mycomm%master) 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%master) 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%masterrank) + !! \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) + + @:ensure (.not. mycomm%master .or. size(recv) == size(send) * mycomm%size) + @:ensure (.not. mycomm%master .or.& + & size(recv, dim=${RANK}$) == size(send, dim=${RANK}$) * mycomm%size) + + call getoptarg(mycomm%masterrank, 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%masterrank) + !! \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) + + @:ensure (.not. mycomm%master .or. size(recv) == ${SIZE}$ * mycomm%size) + @:ensure (.not. mycomm%master .or. size(recv, dim=${RANK + 1}$) == mycomm%size) + + call getoptarg(mycomm%masterrank, 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/src/mpifx_gather.m4 b/src/mpifx_gather.m4 deleted file mode 100644 index 353f4ef..0000000 --- a/src/mpifx_gather.m4 +++ /dev/null @@ -1,82 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_gather -dnl ************************************************************************ - -define(`_subroutine_mpifx_gather_dr0',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send/recv buffer rank (1, 2, etc.) -dnl $5: corresponding MPI type -dnl -!> Gathers results on one process (type $1). -!! -!! \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%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_gather_$1(mycomm, send, recv, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$3 - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _assert(.not. mycomm%master .or. size(recv) == size(send) * mycomm%size) - _assert(.not. mycomm%master .or. & - & size(recv, dim=$4) == size(send, dim=$4) * mycomm%size) - - _handle_inoptflag(root0, root, mycomm%masterrank) - call mpi_gather(send, size(send), $5, recv, size(send), & - & $5, root0, mycomm%id, error0) - call handle_errorflag(error0, "MPI_GATHER in mpifx_gather_$1", error) - -end subroutine mpifx_gather_$1 -') - - -define(`_subroutine_mpifx_gather_dr1',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send buffer size (1 or size(send)) -dnl $5: recv buffer rank specifier ((:), (:,:), etc.) -dnl $6: recv buffers rank (1, 2, etc.) -dnl $7: corresponding MPI type -dnl -!> Gathers results on one process (type $1). -!! -!! \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%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_gather_$1(mycomm, send, recv, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$5 - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _assert(.not. mycomm%master .or. size(recv) == $4 * mycomm%size) - _assert(.not. mycomm%master .or. size(recv, dim=$6) == mycomm%size) - - _handle_inoptflag(root0, root, mycomm%masterrank) - call mpi_gather(send, $4, $7, recv, $4, & - & $7, root0, mycomm%id, error0) - call handle_errorflag(error0, "MPI_GATHER in mpifx_gather_$1", error) - -end subroutine mpifx_gather_$1 - -') diff --git a/src/mpifx_get_processor_name.F90 b/src/mpifx_get_processor_name.fpp similarity index 81% rename from src/mpifx_get_processor_name.F90 rename to src/mpifx_get_processor_name.fpp index 9e0e737..aabe73a 100644 --- a/src/mpifx_get_processor_name.F90 +++ b/src/mpifx_get_processor_name.fpp @@ -1,9 +1,6 @@ -include(mpifx_get_processor_name.m4) - !> Contains the extended MPI communicator. module mpifx_get_processor_name_module - use mpifx_helper_module - use mpi + use mpifx_common_module implicit none private @@ -24,8 +21,7 @@ subroutine mpifx_get_processor_name(rankname, error) 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) + call handle_errorflag(error0, "mpi_get_processor_name() in mpifx_get_processor_name", error) if (error0 /= 0) then return end if diff --git a/src/mpifx_get_processor_name.m4 b/src/mpifx_get_processor_name.m4 deleted file mode 100644 index 3b8c873..0000000 --- a/src/mpifx_get_processor_name.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_helper.m4) diff --git a/src/mpifx_helper.F90 b/src/mpifx_helper.F90 deleted file mode 100644 index a160ff6..0000000 --- a/src/mpifx_helper.F90 +++ /dev/null @@ -1,74 +0,0 @@ -include(mpifx_helper.m4) - -!> Exports constants and helper routine(s). -!! \cond HIDDEN -module mpifx_helper_module - use mpi - implicit none - private - - public :: default_tag, sp, dp - public :: handle_errorflag, assertfailed - - !> 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) - -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 - - integer :: aborterror - - if (present(error)) then - error = error0 - elseif (error0 /= 0) then - write(*, "(A)") "Operation failed!" - write(*, "(A)") msg - write(*, "(A,I0)") "Error: ", error0 - 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 - - end subroutine handle_errorflag - - - !> Stops code signalizing failed a - subroutine assertfailed(file, line) - character(*), intent(in) :: file - integer, intent(in) :: line - - integer :: aborterror - - write(*, "(A)") "Assertion failed" - write(*, "(A,A)") "File:", file - write(*, "(A,I0)") "Line:", line - 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 subroutine assertfailed - - -end module mpifx_helper_module - -!> \endcond diff --git a/src/mpifx_helper.fpp b/src/mpifx_helper.fpp new file mode 100644 index 0000000..f0e5206 --- /dev/null +++ b/src/mpifx_helper.fpp @@ -0,0 +1,152 @@ +#:include 'mpifx.fypp' +#:set OPT_ARG_RANKS = (0, 1) + +!> Exports constants and helper routine(s). +!! \cond HIDDEN +module mpifx_helper_module + use, intrinsic :: iso_fortran_env, only : stderr => error_unit + use mpi + implicit none + private + + public :: DEFAULT_TAG, sp, dp + public :: handle_errorflag, ensure_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, 1, 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 ensure condition + !! + subroutine ensure_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, 1, 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 ensure_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/src/mpifx_helper.m4 b/src/mpifx_helper.m4 deleted file mode 100644 index 8bc38af..0000000 --- a/src/mpifx_helper.m4 +++ /dev/null @@ -1,46 +0,0 @@ -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 -') - -dnl Set DEBUG to 1, unless DEBUG is unspecified or explicitely set to 0. -dnl -define(`DEBUG', ifdef(`DEBUG', ifelse(DEBUG, 0, 0, 1), 0)) - -dnl Indicates debug code. -dnl $1 Code. It is only inserted, if DEBUG is defined as 1. -dnl -define(`_debug', ifelse(DEBUG, 1, $1, `')) - -dnl Removing directory part of a file -dnl -define(`basename', `patsubst($1,`.*/',`')') - -dnl Assertion -dnl $1 Condition to check (only inserted if in debug mode). -dnl -define(`_assert', _debug(`dnl -if (.not. ($1)) then - call assertfailed("`basename(__file__)'", `__line__') -end if')) diff --git a/src/mpifx_init.F90 b/src/mpifx_init.fpp similarity index 97% rename from src/mpifx_init.F90 rename to src/mpifx_init.fpp index 344304a..e165941 100644 --- a/src/mpifx_init.F90 +++ b/src/mpifx_init.fpp @@ -1,5 +1,3 @@ -include(mpifx_init.m4) - !> Contains wrapper for \c MPI_INIT. module mpifx_init_module use mpifx_common_module diff --git a/src/mpifx_init.m4 b/src/mpifx_init.m4 deleted file mode 100644 index 40a7479..0000000 --- a/src/mpifx_init.m4 +++ /dev/null @@ -1 +0,0 @@ -include(mpifx_common.m4) diff --git a/src/mpifx_recv.F90 b/src/mpifx_recv.F90 deleted file mode 100644 index aa4d079..0000000 --- a/src/mpifx_recv.F90 +++ /dev/null @@ -1,145 +0,0 @@ -include(mpifx_recv.m4) - -!> 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%master) then - !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" - !! call mpifx_send(mycomm, msg, mycomm%masterrank) - !! else - !! write(*, "(A)") "Master 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 - 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_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_recv_module diff --git a/src/mpifx_recv.fpp b/src/mpifx_recv.fpp new file mode 100644 index 0000000..d63a2d3 --- /dev/null +++ b/src/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%master) then + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + !! call mpifx_send(mycomm, msg, mycomm%masterrank) + !! else + !! write(*, "(A)") "Master 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/src/mpifx_recv.m4 b/src/mpifx_recv.m4 deleted file mode 100644 index 93cb2b7..0000000 --- a/src/mpifx_recv.m4 +++ /dev/null @@ -1,39 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_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 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_$1(mycomm, msg, source, tag, status, error) - type(mpifx_comm), intent(in) :: mycomm - $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, mycomm%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/src/mpifx_reduce.F90 b/src/mpifx_reduce.F90 deleted file mode 100644 index 80539b5..0000000 --- a/src/mpifx_reduce.F90 +++ /dev/null @@ -1,258 +0,0 @@ -include(mpifx_reduce.m4) - -!> 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 - module procedure mpifx_reduce_i0, mpifx_reduce_i1, mpifx_reduce_i2, & - & mpifx_reduce_i3, mpifx_reduce_i4, mpifx_reduce_i5, mpifx_reduce_i6 - module procedure mpifx_reduce_s0, mpifx_reduce_s1, mpifx_reduce_s2, & - & mpifx_reduce_s3, mpifx_reduce_s4, mpifx_reduce_s5, mpifx_reduce_s6 - module procedure mpifx_reduce_d0, mpifx_reduce_d1, mpifx_reduce_d2, & - & mpifx_reduce_d3, mpifx_reduce_d4, mpifx_reduce_d5, mpifx_reduce_d6 - module procedure mpifx_reduce_c0, mpifx_reduce_c1, mpifx_reduce_c2, & - & mpifx_reduce_c3, mpifx_reduce_c4, mpifx_reduce_c5, mpifx_reduce_c6 - module procedure mpifx_reduce_z0, mpifx_reduce_z1, mpifx_reduce_z2, & - & mpifx_reduce_z3, mpifx_reduce_z4, mpifx_reduce_z5, mpifx_reduce_z6 - module procedure mpifx_reduce_l0, mpifx_reduce_l1, mpifx_reduce_l2, & - & mpifx_reduce_l3, mpifx_reduce_l4, mpifx_reduce_l5, mpifx_reduce_l6 - 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 - module procedure mpifx_reduceip_i0, mpifx_reduceip_i1, mpifx_reduceip_i2, & - & mpifx_reduceip_i3, mpifx_reduceip_i4, mpifx_reduceip_i5, & - & mpifx_reduceip_i6 - module procedure mpifx_reduceip_s0, mpifx_reduceip_s1, mpifx_reduceip_s2, & - & mpifx_reduceip_s3, mpifx_reduceip_s4, mpifx_reduceip_s5, & - & mpifx_reduceip_s6 - module procedure mpifx_reduceip_d0, mpifx_reduceip_d1, mpifx_reduceip_d2, & - & mpifx_reduceip_d3, mpifx_reduceip_d4, mpifx_reduceip_d5, & - & mpifx_reduceip_d6 - module procedure mpifx_reduceip_c0, mpifx_reduceip_c1, mpifx_reduceip_c2, & - & mpifx_reduceip_c3, mpifx_reduceip_c4, mpifx_reduceip_c5, & - & mpifx_reduceip_c6 - module procedure mpifx_reduceip_z0, mpifx_reduceip_z1, mpifx_reduceip_z2, & - & mpifx_reduceip_z3, mpifx_reduceip_z4, mpifx_reduceip_z5, & - & mpifx_reduceip_z6 - module procedure mpifx_reduceip_l0, mpifx_reduceip_l1, mpifx_reduceip_l2, & - & mpifx_reduceip_l3, mpifx_reduceip_l4, mpifx_reduceip_l5, & - & mpifx_reduceip_l6 - end interface mpifx_reduceip - - -contains - - _subroutine_mpifx_reduce(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_reduce(i1, integer, (:), size(operand), MPI_INTEGER) - _subroutine_mpifx_reduce(i2, integer, (:,:), size(operand), MPI_INTEGER) - _subroutine_mpifx_reduce(i3, integer, (:,:,:), size(operand), MPI_INTEGER) - _subroutine_mpifx_reduce(i4, integer, (:,:,:,:), size(operand), MPI_INTEGER) - _subroutine_mpifx_reduce(i5, integer, (:,:,:,:,:), size(operand), MPI_INTEGER) - _subroutine_mpifx_reduce(i6, integer, (:,:,:,:,:,:), size(operand), - MPI_INTEGER) - - _subroutine_mpifx_reduce(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_reduce(s1, real(sp), (:), size(operand), MPI_REAL) - _subroutine_mpifx_reduce(s2, real(sp), (:,:), size(operand), MPI_REAL) - _subroutine_mpifx_reduce(s3, real(sp), (:,:,:), size(operand), MPI_REAL) - _subroutine_mpifx_reduce(s4, real(sp), (:,:,:,:), size(operand), MPI_REAL) - _subroutine_mpifx_reduce(s5, real(sp), (:,:,:,:,:), size(operand), MPI_REAL) - _subroutine_mpifx_reduce(s6, real(sp), (:,:,:,:,:,:), size(operand), - MPI_REAL) - - _subroutine_mpifx_reduce(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduce(d1, real(dp), (:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduce(d2, real(dp), (:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduce(d3, real(dp), (:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduce(d4, real(dp), (:,:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduce(d5, real(dp), (:,:,:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduce(d6, real(dp), (:,:,:,:,:,:), size(operand), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_reduce(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_reduce(c1, complex(sp), (:), size(operand), MPI_COMPLEX) - _subroutine_mpifx_reduce(c2, complex(sp), (:,:), size(operand), MPI_COMPLEX) - _subroutine_mpifx_reduce(c3, complex(sp), (:,:,:), size(operand), MPI_COMPLEX) - _subroutine_mpifx_reduce(c4, complex(sp), (:,:,:,:), size(operand), - MPI_COMPLEX) - _subroutine_mpifx_reduce(c5, complex(sp), (:,:,:,:,:), size(operand), - MPI_COMPLEX) - _subroutine_mpifx_reduce(c6, complex(sp), (:,:,:,:,:,:), size(operand), - MPI_COMPLEX) - - _subroutine_mpifx_reduce(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduce(z1, complex(dp), (:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduce(z2, complex(dp), (:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduce(z3, complex(dp), (:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduce(z4, complex(dp), (:,:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduce(z5, complex(dp), (:,:,:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduce(z6, complex(dp), (:,:,:,:,:,:), size(operand), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_reduce(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_reduce(l1, logical, (:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_reduce(l2, logical, (:,:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_reduce(l3, logical, (:,:,:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_reduce(l4, logical, (:,:,:,:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_reduce(l5, logical, (:,:,:,:,:), size(operand), MPI_LOGICAL) - _subroutine_mpifx_reduce(l6, logical, (:,:,:,:,:,:), size(operand), - MPI_LOGICAL) - - _subroutine_mpifx_reduceip(i0, integer, , 1, MPI_INTEGER) - _subroutine_mpifx_reduceip(i1, integer, (:), size(opres), MPI_INTEGER) - _subroutine_mpifx_reduceip(i2, integer, (:,:), size(opres), MPI_INTEGER) - _subroutine_mpifx_reduceip(i3, integer, (:,:,:), size(opres), MPI_INTEGER) - _subroutine_mpifx_reduceip(i4, integer, (:,:,:,:), size(opres), MPI_INTEGER) - _subroutine_mpifx_reduceip(i5, integer, (:,:,:,:,:), size(opres), - MPI_INTEGER) - _subroutine_mpifx_reduceip(i6, integer, (:,:,:,:,:,:), size(opres), - MPI_INTEGER) - - _subroutine_mpifx_reduceip(s0, real(sp), , 1, MPI_REAL) - _subroutine_mpifx_reduceip(s1, real(sp), (:), size(opres), MPI_REAL) - _subroutine_mpifx_reduceip(s2, real(sp), (:,:), size(opres), MPI_REAL) - _subroutine_mpifx_reduceip(s3, real(sp), (:,:,:), size(opres), MPI_REAL) - _subroutine_mpifx_reduceip(s4, real(sp), (:,:,:,:), size(opres), MPI_REAL) - _subroutine_mpifx_reduceip(s5, real(sp), (:,:,:,:,:), size(opres), MPI_REAL) - _subroutine_mpifx_reduceip(s6, real(sp), (:,:,:,:,:,:), size(opres), - MPI_REAL) - - _subroutine_mpifx_reduceip(d0, real(dp), , 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduceip(d1, real(dp), (:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduceip(d2, real(dp), (:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduceip(d3, real(dp), (:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduceip(d4, real(dp), (:,:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduceip(d5, real(dp), (:,:,:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_reduceip(d6, real(dp), (:,:,:,:,:,:), size(opres), - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_reduceip(c0, complex(sp), , 1, MPI_COMPLEX) - _subroutine_mpifx_reduceip(c1, complex(sp), (:), size(opres), MPI_COMPLEX) - _subroutine_mpifx_reduceip(c2, complex(sp), (:,:), size(opres), MPI_COMPLEX) - _subroutine_mpifx_reduceip(c3, complex(sp), (:,:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_reduceip(c4, complex(sp), (:,:,:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_reduceip(c5, complex(sp), (:,:,:,:,:), size(opres), - MPI_COMPLEX) - _subroutine_mpifx_reduceip(c6, complex(sp), (:,:,:,:,:,:), size(opres), - MPI_COMPLEX) - - _subroutine_mpifx_reduceip(z0, complex(dp), , 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduceip(z1, complex(dp), (:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduceip(z2, complex(dp), (:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduceip(z3, complex(dp), (:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduceip(z4, complex(dp), (:,:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduceip(z5, complex(dp), (:,:,:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_reduceip(z6, complex(dp), (:,:,:,:,:,:), size(opres), - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_reduceip(l0, logical, , 1, MPI_LOGICAL) - _subroutine_mpifx_reduceip(l1, logical, (:), size(opres), MPI_LOGICAL) - _subroutine_mpifx_reduceip(l2, logical, (:,:), size(opres), MPI_LOGICAL) - _subroutine_mpifx_reduceip(l3, logical, (:,:,:), size(opres), MPI_LOGICAL) - _subroutine_mpifx_reduceip(l4, logical, (:,:,:,:), size(opres), MPI_LOGICAL) - _subroutine_mpifx_reduceip(l5, logical, (:,:,:,:,:), size(opres), - MPI_LOGICAL) - _subroutine_mpifx_reduceip(l6, logical, (:,:,:,:,:,:), size(opres), - MPI_LOGICAL) - - -end module mpifx_reduce_module diff --git a/src/mpifx_reduce.fpp b/src/mpifx_reduce.fpp new file mode 100644 index 0000000..83c4820 --- /dev/null +++ b/src/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%masterrank) + !! \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%masterrank, 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%masterrank) + !! \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%masterrank, 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/src/mpifx_reduce.m4 b/src/mpifx_reduce.m4 deleted file mode 100644 index a81d0e4..0000000 --- a/src/mpifx_reduce.m4 +++ /dev/null @@ -1,78 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_reduce -dnl ************************************************************************ - -define(`_subroutine_mpifx_reduce',`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 -!> Reduces results on one process (type $1). -!! -!! \param mycomm MPI communicator. -!! \param operand Quantity to be reduced. -!! \param result Contains result on exit. -!! \param operator Reduction operator -!! \param root Root process for the result (default: mycomm%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_reduce_$1(mycomm, operand, result, operator, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: operand$3 - $2, intent(inout) :: result$3 - integer, intent(in) :: operator - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _handle_inoptflag(root0, root, mycomm%masterrank) - call mpi_reduce(operand, result, $4, $5, operator, root0, mycomm%id, error0) - call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_$1", error) - -end subroutine mpifx_reduce_$1 -') - -dnl ************************************************************************ -dnl *** mpifx_reduceip -dnl ************************************************************************ - -define(`_subroutine_mpifx_reduceip',`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 -!> Reduces results on one process (type $1). -!! -!! \param mycomm MPI communicator. -!! \param opres Quantity to be reduced on input, result on exit -!! \param operator Reduction operator -!! \param root Root process for the result (default: mycomm%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_reduceip_$1(mycomm, opres, operator, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(inout) :: opres$3 - integer, intent(in) :: operator - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - $2 :: dummy - - _handle_inoptflag(root0, root, mycomm%masterrank) - if (mycomm%rank == root0) then - call mpi_reduce(MPI_IN_PLACE, opres, $4, $5, operator, root0, mycomm%id, & - & error0) - else - call mpi_reduce(opres, dummy, $4, $5, operator, root0, mycomm%id, & - & error0) - end if - call handle_errorflag(error0, "MPI_REDUCE in mpifx_reduce_$1", error) - -end subroutine mpifx_reduceip_$1 -') diff --git a/src/mpifx_scatter.F90 b/src/mpifx_scatter.F90 deleted file mode 100644 index bee26de..0000000 --- a/src/mpifx_scatter.F90 +++ /dev/null @@ -1,254 +0,0 @@ -include(mpifx_scatter.m4) - -!> 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%master) 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%master) 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%master) 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 - module procedure & - & mpifx_scatter_i1i1, mpifx_scatter_i2i2, mpifx_scatter_i3i3, & - & mpifx_scatter_i4i4, mpifx_scatter_i5i5, mpifx_scatter_i6i6 - module procedure & - & mpifx_scatter_i1i0, mpifx_scatter_i2i1, mpifx_scatter_i3i2, & - & mpifx_scatter_i4i3, mpifx_scatter_i5i4, mpifx_scatter_i6i5 - module procedure & - & mpifx_scatter_s1s1, mpifx_scatter_s2s2, mpifx_scatter_s3s3, & - & mpifx_scatter_s4s4, mpifx_scatter_s5s5, mpifx_scatter_s6s6 - module procedure & - & mpifx_scatter_s1s0, mpifx_scatter_s2s1, mpifx_scatter_s3s2, & - & mpifx_scatter_s4s3, mpifx_scatter_s5s4, mpifx_scatter_s6s5 - module procedure & - & mpifx_scatter_d1d1, mpifx_scatter_d2d2, mpifx_scatter_d3d3, & - & mpifx_scatter_d4d4, mpifx_scatter_d5d5, mpifx_scatter_d6d6 - module procedure & - & mpifx_scatter_d1d0, mpifx_scatter_d2d1, mpifx_scatter_d3d2, & - & mpifx_scatter_d4d3, mpifx_scatter_d5d4, mpifx_scatter_d6d5 - module procedure & - & mpifx_scatter_c1c1, mpifx_scatter_c2c2, mpifx_scatter_c3c3, & - & mpifx_scatter_c4c4, mpifx_scatter_c5c5, mpifx_scatter_c6c6 - module procedure & - & mpifx_scatter_c1c0, mpifx_scatter_c2c1, mpifx_scatter_c3c2, & - & mpifx_scatter_c4c3, mpifx_scatter_c5c4, mpifx_scatter_c6c5 - module procedure & - & mpifx_scatter_z1z1, mpifx_scatter_z2z2, mpifx_scatter_z3z3, & - & mpifx_scatter_z4z4, mpifx_scatter_z5z5, mpifx_scatter_z6z6 - module procedure & - & mpifx_scatter_z1z0, mpifx_scatter_z2z1, mpifx_scatter_z3z2, & - & mpifx_scatter_z4z3, mpifx_scatter_z5z4, mpifx_scatter_z6z5 - module procedure & - & mpifx_scatter_l1l1, mpifx_scatter_l2l2, mpifx_scatter_l3l3, & - & mpifx_scatter_l4l4, mpifx_scatter_l5l5, mpifx_scatter_l6l6 - module procedure & - & mpifx_scatter_l1l0, mpifx_scatter_l2l1, mpifx_scatter_l3l2, & - & mpifx_scatter_l4l3, mpifx_scatter_l5l4, mpifx_scatter_l6l5 - end interface mpifx_scatter - - -contains - - _subroutine_mpifx_scatter_dr0(i1i1, integer, (:), 1, MPI_INTEGER) - _subroutine_mpifx_scatter_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) - _subroutine_mpifx_scatter_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - _subroutine_mpifx_scatter_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - _subroutine_mpifx_scatter_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_scatter_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - _subroutine_mpifx_scatter_dr1(i1i0, integer, , 1, (:), 1, MPI_INTEGER) - _subroutine_mpifx_scatter_dr1(i2i1, integer, (:), size(recv), (:,:), 2, - MPI_INTEGER) - _subroutine_mpifx_scatter_dr1(i3i2, integer, (:,:), size(recv), (:,:,:), 3, - MPI_INTEGER) - _subroutine_mpifx_scatter_dr1(i4i3, integer, (:,:,:), size(recv), (:,:,:,:), - 4, MPI_INTEGER) - _subroutine_mpifx_scatter_dr1(i5i4, integer, (:,:,:,:), size(recv), - (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_scatter_dr1(i6i5, integer, (:,:,:,:,:), size(recv), - (:,:,:,:,:,:), 6, MPI_INTEGER) - - - _subroutine_mpifx_scatter_dr0(s1s1, real(sp), (:), 1, MPI_REAL) - _subroutine_mpifx_scatter_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) - _subroutine_mpifx_scatter_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - _subroutine_mpifx_scatter_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - _subroutine_mpifx_scatter_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_scatter_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - _subroutine_mpifx_scatter_dr1(s1s0, real(sp), , 1, (:), 1, MPI_REAL) - _subroutine_mpifx_scatter_dr1(s2s1, real(sp), (:), size(recv), (:,:), 2, - MPI_REAL) - _subroutine_mpifx_scatter_dr1(s3s2, real(sp), (:,:), size(recv), (:,:,:), 3, - MPI_REAL) - _subroutine_mpifx_scatter_dr1(s4s3, real(sp), (:,:,:), size(recv), (:,:,:,:), - 4, MPI_REAL) - _subroutine_mpifx_scatter_dr1(s5s4, real(sp), (:,:,:,:), size(recv), - (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_scatter_dr1(s6s5, real(sp), (:,:,:,:,:), size(recv), - (:,:,:,:,:,:), 6, MPI_REAL) - - - _subroutine_mpifx_scatter_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr0(d3d3, real(dp), (:,:,:), 3, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr0(d4d4, real(dp), (:,:,:,:), 4, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr0(d5d5, real(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_PRECISION) - - _subroutine_mpifx_scatter_dr1(d1d0, real(dp), , 1, (:), 1, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr1(d2d1, real(dp), (:), size(recv), (:,:), 2, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr1(d3d2, real(dp), (:,:), size(recv), (:,:,:), 3, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr1(d4d3, real(dp), (:,:,:), size(recv), (:,:,:,:), - 4, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr1(d5d4, real(dp), (:,:,:,:), size(recv), - (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_scatter_dr1(d6d5, real(dp), (:,:,:,:,:), size(recv), - (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) - - - _subroutine_mpifx_scatter_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, - MPI_COMPLEX) - - _subroutine_mpifx_scatter_dr1(c1c0, complex(sp), , 1, (:), 1, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr1(c2c1, complex(sp), (:), size(recv), (:,:), 2, - MPI_COMPLEX) - _subroutine_mpifx_scatter_dr1(c3c2, complex(sp), (:,:), size(recv), (:,:,:), - 3, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr1(c4c3, complex(sp), (:,:,:), size(recv), - (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr1(c5c4, complex(sp), (:,:,:,:), size(recv), - (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_scatter_dr1(c6c5, complex(sp), (:,:,:,:,:), size(recv), - (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - _subroutine_mpifx_scatter_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr0(z3z3, complex(dp), (:,:,:), 3, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr0(z4z4, complex(dp), (:,:,:,:), 4, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_COMPLEX) - - _subroutine_mpifx_scatter_dr1(z1z0, complex(dp), , 1, (:), 1, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr1(z2z1, complex(dp), (:), size(recv), (:,:), 2, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr1(z3z2, complex(dp), (:,:), size(recv), (:,:,:), - 3, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr1(z4z3, complex(dp), (:,:,:), size(recv), - (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr1(z5z4, complex(dp), (:,:,:,:), size(recv), - (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_scatter_dr1(z6z5, complex(dp), (:,:,:,:,:), size(recv), - (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) - - - _subroutine_mpifx_scatter_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - _subroutine_mpifx_scatter_dr1(l1l0, logical, , 1, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr1(l2l1, logical, (:), size(recv), (:,:), 2, - MPI_LOGICAL) - _subroutine_mpifx_scatter_dr1(l3l2, logical, (:,:), size(recv), (:,:,:), 3, - MPI_LOGICAL) - _subroutine_mpifx_scatter_dr1(l4l3, logical, (:,:,:), size(recv), (:,:,:,:), - 4, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr1(l5l4, logical, (:,:,:,:), size(recv), - (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_scatter_dr1(l6l5, logical, (:,:,:,:,:), size(recv), - (:,:,:,:,:,:), 6, MPI_LOGICAL) - - -end module mpifx_scatter_module diff --git a/src/mpifx_scatter.fpp b/src/mpifx_scatter.fpp new file mode 100644 index 0000000..563fbb5 --- /dev/null +++ b/src/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%master) 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%master) 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%master) 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 INT_TYPES + FLOAT_TYPES + LOGICAL_TYPES + #:for RANK in range(1, MAX_RANK + 1) + #: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%masterrank) + !! \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(send)' + #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + + @:ensure (.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) + @:ensure (.not. mycomm%master& + & .or. size(send, dim=${RANK}$) == size(recv, dim=${RANK}$) * mycomm%size) + + call getoptarg(mycomm%masterrank, 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%masterrank) + !! \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(send) * ' + SIZE if HASLENGTH else SIZE) + + @:ensure (.not. mycomm%master .or. size(send) == ${SIZE}$ * mycomm%size) + @:ensure (.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%size) + #:if HASLENGTH + @:ensure (.not. mycomm%master .or. len(send) == len(recv)) + #:endif + + call getoptarg(mycomm%masterrank, 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/src/mpifx_scatter.m4 b/src/mpifx_scatter.m4 deleted file mode 100644 index 9242fac..0000000 --- a/src/mpifx_scatter.m4 +++ /dev/null @@ -1,82 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_scatter -dnl ************************************************************************ - -define(`_subroutine_mpifx_scatter_dr0',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send/recv buffer rank (1, 2, etc.) -dnl $5: corresponding MPI type -dnl -!> Scatters object from one process (type $1). -!! -!! \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%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_scatter_$1(mycomm, send, recv, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$3 - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _assert(.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) - _assert(.not. mycomm%master .or. & - & size(send, dim=$4) == size(recv, dim=$4) * mycomm%size) - - _handle_inoptflag(root0, root, mycomm%masterrank) - call mpi_scatter(send, size(recv), $5, recv, size(recv), & - & $5, root0, mycomm%id, error0) - call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatter_$1", error) - -end subroutine mpifx_scatter_$1 -') - - -define(`_subroutine_mpifx_scatter_dr1',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: recv buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: recv buffer size (1 or size(recv)) -dnl $5: send buffer rank specifier ((:), (:,:), etc.) -dnl $6: send buffer rank (1, 2, etc.) -dnl $7: corresponding MPI type -dnl -!> Scatters results on one process (type $1). -!! -!! \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%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_scatter_$1(mycomm, send, recv, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$5 - $2, intent(out) :: recv$3 - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: root0, error0 - - _assert(.not. mycomm%master .or. size(send) == $4 * mycomm%size) - _assert(.not. mycomm%master .or. size(send, dim=$6) == mycomm%size) - - _handle_inoptflag(root0, root, mycomm%masterrank) - call mpi_scatter(send, $4, $7, recv, $4, & - & $7, root0, mycomm%id, error0) - call handle_errorflag(error0, "MPI_SCATTER in mpifx_scatter_$1", error) - -end subroutine mpifx_scatter_$1 - -') diff --git a/src/mpifx_send.F90 b/src/mpifx_send.F90 deleted file mode 100644 index 0b67c36..0000000 --- a/src/mpifx_send.F90 +++ /dev/null @@ -1,146 +0,0 @@ -include(mpifx_send.m4) - -!> 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%master) then - !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" - !! call mpifx_send(mycomm, msg, mycomm%masterrank) - !! else - !! write(*, "(A)") "Master 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 - 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 - - -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) - - -end module mpifx_send_module diff --git a/src/mpifx_send.fpp b/src/mpifx_send.fpp new file mode 100644 index 0000000..2b8f698 --- /dev/null +++ b/src/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%master) then + !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" + !! call mpifx_send(mycomm, msg, mycomm%masterrank) + !! else + !! write(*, "(A)") "Master 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/src/mpifx_send.m4 b/src/mpifx_send.m4 deleted file mode 100644 index 5f60be7..0000000 --- a/src/mpifx_send.m4 +++ /dev/null @@ -1,34 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_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 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_$1(mycomm, msg, dest, tag, error) - type(mpifx_comm), intent(in) :: mycomm - $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, mycomm%id, error0) - call handle_errorflag(error0, "MPI_SEND in mpifx_send_$1", error) - -end subroutine mpifx_send_$1 -') diff --git a/test/GNUmakefile b/test/GNUmakefile index 70e8b92..8d8b01e 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -9,8 +9,11 @@ include ../make.arch +# Root directory +ROOT = .. + # Directory where library source can be found -SRCDIR = ../src +SRCDIR = $(ROOT)/src ############################################################################ # Building the test programs. @@ -20,7 +23,7 @@ SRCDIR = ../src ############################################################################ .SUFFIXES: -.SUFFIXES: .f90 .F90 .o .m4 +.SUFFIXES: .f90 .o TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ test_allreduce test_gather test_allgather test_scatter @@ -63,5 +66,5 @@ _FORCED_SUBMAKE_: $(MAKE) \ FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="$(M4OPT)" \ + FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" \ -C $(SRCDIR) -f Makefile.lib diff --git a/utils/cr_makedep b/utils/cr_makedep new file mode 100755 index 0000000..cb52d73 --- /dev/null +++ b/utils/cr_makedep @@ -0,0 +1,394 @@ +#!/usr/bin/env python +############################################################################### +# +# Copyright (c) 2013, Balint 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. +# +############################################################################### +from __future__ import print_function +import argparse +import re +import os +import copy + +DESCRIPTION = """Creates dependency information for the GNU Make system by +analyzing Fortran 90+ source files. + +It searches the source files in the given directory for module inclusions and +module definitions (via the 'use' and 'module' statements). In every directory +it creates a file 'Makefile.dep' which can be included by the actual makefile. +If the source files contain CPP conditionals (#if, #ifdef, #else, +#endif), they will be included in the dependency file, so that preprocessing +the dependency file with CPP will give the correct dependencies. +""" + +# Patterns for branch constructs: #if*, #else, #endif +PAT_IF = re.compile(r"^[ \t]*#[ \t]*if(?P(?:n?def)?[ \t]+.*)$", + re.MULTILINE) +PAT_ELSE = re.compile(r"^[ \t]*#[ \t]*else[ \t]*$", re.MULTILINE) +PAT_ENDIF = re.compile(r"^[ \t]*#[ \t]*endif\s*$", re.MULTILINE) + +# Patterns for other constructs: #include, use, module +PAT_INCLUDE = re.compile(r"""^[ \t]*\#[ \t]*include\s+ + (?:'(?P[^']+)' + |\"(?P[^\"]+)\") + """, re.MULTILINE | re.VERBOSE) + +PAT_USE = re.compile(r"^[ \t]*use[ \t]+(?P[^ \s,]*)", + re.MULTILINE | re.IGNORECASE) + +PAT_MODULE = re.compile(r"^[ \t]*module[ \t]+(?P\S+)[ \t]*$", + re.MULTILINE | re.IGNORECASE) + +PAT_INCLUDE2 = re.compile(r"^[ \t]*include\s*['\"(](?P[^'\")]+)['\")]", + re.MULTILINE | re.IGNORECASE) + +# List of all patterns +PATTERNS = ( PAT_IF, PAT_ELSE, PAT_ENDIF, PAT_INCLUDE, PAT_USE, PAT_MODULE, + PAT_INCLUDE2 ) + +# Dependency information types +DEP_MODULE = 0 +DEP_INCLUDE = 1 + +# Definition types +DFN_MODULE = 0 + +# Pattern to select files to process: +PAT_FILE = re.compile(r"\.f90$|\.h$|\.inc|\.fpp$", re.IGNORECASE) + +# Extensions to be considered Fortran source files +FORTRAN_EXTENSIONS = (".f90", ".f", ".fpp") + +# Name of the dependency output +DEPFILE = "Makefile.dep" + +class MakedepException(Exception): + pass + + +class BranchBlock(object): + """Contains information on a block which may contain dependency information + and a branch point""" + + def __init__(self): + """Initialises a BranchBlock""" + self._dependencies = set() # Dependencies + self._definitions = set() # Defined entities + self._condition = "" # Condition for the branch point + self._truechild = None # True block of the branch + self._falsechild = None # False block of the branch + self._hasbranch = False # If current block contains a branch + + + def add_dependency(self, dep, deptype): + """Adds a dependency to the current block + dep -- name of the dependency + deptype -- type of the dependency + """ + self._dependencies.add((dep, deptype)) + + + def add_definition(self, dfn, dfntype): + """Adds a dependency to the current block + dfn -- name of the definition + deptype -- type of the definition + """ + self._definitions.add((dfn, dfntype)) + + + def add_branch(self, condition, true, false): + """Adds a branch to the current block + condition -- Branching condition + true -- True block of the branch + false -- False block of the branch + """ + # Make sure, all branches are proper objects + true = true or BranchBlock() + false = false or BranchBlock() + + if self._hasbranch: + # We have a branch point already, add new branch to them + if self._condition == condition: + self._truechild.extendBlock(true) + self._falsechild.extendBlock(false) + else: + self._truechild.add_branch(condition, true, false) + self._falsechild.add_branch(condition, true, false) + else: + # No branch point yet: branch point added to the current block + self._hasbranch = True + self._condition = condition + self._truechild = copy.deepcopy(true) + self._falsechild = copy.deepcopy(false) + + + def extend_block(self, block): + """Extends a block with the content of an other one. + block -- Contains the information to add + """ + self._dependencies.update(block._dependencies) + self._definitions.update(block._definitions) + if block._hasbranch: + self.add_branch(block._condition, block._truechild, + block._falsechild) + + + def hasbranch(self): + """Returns flag, if current block contains a branch or not""" + return self._hasbranch + + + def has_deps_or_defs(self): + """Flags, if current block contains any dependencies or definitions""" + return (len(self._dependencies) != 0 or len(self._definitions) != 0) + + + def write_tree(self, fp, fbase, fext, fsrc): + """Prints the dependency tree in the appropriate format + fp -- pointer to an open file + fbase -- base name of the processed file + fext -- extension of the processed file + fsrc -- flags if processed file was a fortran file or not + (A more elegant implementation would do this with a writer class...) + """ + self._write_tree_recursive(fp, [], [], fbase, fext, fsrc) + + + def _write_tree_recursive(self, fp, deps, defs, fbase, fext, fsrc): + """Working horse for the write_tree routine + fp: file pointer + deps: Dependencies so far + defs: Definitions so far + fbase: base name of the processed file + fext: extension of the processed file + fsrc: flags if processed file was a fortran source file + """ + + newdeps = deps + list(self._dependencies) + newdefs = defs + list(self._definitions) + + if self._hasbranch: + # We have a branch point, dive into the true and false branch + fp.write("#if{}\n".format(self._condition)) + self._truechild._write_tree_recursive(fp, newdeps, newdefs, fbase, + fext, fsrc) + fp.write("#else\n") + self._falsechild._write_tree_recursive(fp, newdeps, newdefs, fbase, + fext, fsrc) + fp.write("#endif\n") + else: + # No further branch points: write all dependencies in order + filedeps = [] + vardeps = [] + for (depname, deptype) in newdeps: + if deptype == DEP_MODULE: + filedeps.append("$$({0}{1})".format("_modobj_", depname)) + vardeps.append("$($({0}{1}))".format("_modobj_", depname)) + else: + filedeps.append(depname) + vardeps.append("$({0})".format(depname)) + if fsrc: + fp.write("{0}.o: ".format(fbase)) + if filedeps: + fp.write(" ".join(filedeps)) + fp.write("\n") + fp.write("{0}.o = {0}.o ".format(fbase)) + if vardeps: + fp.write(" ".join(vardeps)) + fp.write("\n") + else: + if filedeps: + fp.write("{0}{1}: ".format(fbase, fext)) + fp.write(" ".join(filedeps) + "\n") + fp.write("{0}{1} = ".format(fbase, fext)) + if vardeps: + fp.write(" ".join(vardeps)) + fp.write("\n") + + # Write definitions: + for (dfnname, dfntype) in newdefs: + if dfntype == DFN_MODULE: + fp.write("{0}{1} = {2}.o\n".format("_modobj_", dfnname, + fbase)) + + +def build_dependency_tree(txt): + """Creates a dependency tree for the given text""" + + end = len(txt) + matches = [ pat.search(txt) for pat in PATTERNS ] + starts = [] + for match in matches: + if match: + starts.append(match.start()) + else: + starts.append(end) + (itype, node) = build_dependency_recursive(txt, matches, starts) + return node + + + +def nextmatch(txt, matches, starts, itype): + # Helper function for build_dependency_recursive, updating matches and + # starts by replacing the entries for itype with the next occurance. + + if matches[itype] == None: + raise MakedepException("Invalid nesting of blocks " + "(probably unclosed #if* block)") + match = PATTERNS[itype].search(txt, matches[itype].end()) + matches[itype] = match + if match: + starts[itype] = match.start() + else: + starts[itype] = len(txt) + + +def build_dependency_recursive(txt, matches, starts): + """Working function for the build_dependency_tree routine. + txt -- text to parse + matches -- last match for each pattern in PATTERNS + starts -- starting position of the last matches (len(txt) if no match) + return -- (itype, node), where itype is the type of the closing block + and node is the tree built. + """ + + block = BranchBlock() + end = len(txt) + firstpos = min(starts) + itype = -1 + + # Loop as long we did not reach the end of the text + while firstpos < end: + + # get entry type and match object for the first pttern match + itype = starts.index(firstpos) + match = matches[itype] + + if itype == 0: + # Branch opening (#ifdef) + condition = match.group("cond") + nextmatch(txt, matches, starts, itype) + (itype, ifbranch) = build_dependency_recursive(txt, matches, starts) + if itype == 1: + # If branch ended with #else -> parse the else branch as well + nextmatch(txt, matches, starts, itype) + (itype, elsebranch) = build_dependency_recursive(txt, matches, + starts) + else: + elsebranch = None + # Sanity check: #if must be closed by #endif + if itype != 2: + raise MakedepException("ERROR, #else must be terminted by " + "#endif") + # if any of the two branches contains usefull info, add the branch + # to the current block + if ifbranch or elsebranch: + block.add_branch(condition, ifbranch, elsebranch) + elif itype == 1 or itype == 2: + # block closing #else or #endif found -> escape to higher level + break + elif itype == 3: + # #include found + groups = match.groups() + name = groups[0] + if not name: + name = groups[1] + block.add_dependency(name, DEP_INCLUDE) + elif itype == 4: + # module found + block.add_dependency(match.group("mod").lower(), DEP_MODULE) + elif itype == 5: + # module defintion found + block.add_definition(match.group("mod").lower(), DFN_MODULE) + elif itype == 6: + # include with ' or " or () + block.add_dependency(match.group("name"), DEP_INCLUDE) + else: + raise MakedepException("Unknown itype: {:d}".format(itype)) + + # Get next occurance for processed entry + nextmatch(txt, matches, starts, itype) + firstpos = min(starts) + + # Pass block back, if it contains usefull info + if block.has_deps_or_defs() or block.hasbranch(): + return (itype, block) + else: + return (itype, None) + + +def write_depfile(fp, sources): + """Writes dependency file. + fp -- File descriptor for file to write to. + sources -- Fortran source files to investigate + """ + + fp.write(".SECONDEXPANSION:\n\n") + for source in sources: + print("Processing: {}".format(source)) + fpsource = open(source, "r") + txt = fpsource.read() + fpsource.close() + tree = build_dependency_tree(txt) + if tree: + fbase, fext = os.path.splitext(os.path.basename(source)) + fextlow = fext.lower() + fsrc = fextlow in FORTRAN_EXTENSIONS + tree.write_tree(fp, fbase, fext, fsrc) + fp.write("\n") + + + +def main(): + """Main procedure""" + + parser = argparse.ArgumentParser(description=DESCRIPTION) + parser.add_argument( + 'dirnames', metavar='DIR', nargs='*', default=["."], + help="Directory in which dependency file should be created " + "(default: '.')") + + args = parser.parse_args() + + for dirname in args.dirnames: + outname = os.path.join(dirname, DEPFILE) + print("Creating:", outname) + fp = open(outname, "w") + fnames = [ os.path.join(dirname, fname) + for fname in os.listdir(dirname) + if PAT_FILE.search(fname) ] + write_depfile(fp, fnames) + fp.close() + + +if __name__ == "__main__": + main() + + +### Local Variables: +### mode:python +### End: From 94e8e237ccd3203ee5f985c0804a7fa1726bddc9 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Tue, 11 Aug 2015 10:03:56 +0100 Subject: [PATCH 12/72] Minor comment typos fixed. --- src/mpifx_recv.m4 | 2 +- src/mpifx_send.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mpifx_recv.m4 b/src/mpifx_recv.m4 index 93cb2b7..b4c84b8 100644 --- a/src/mpifx_recv.m4 +++ b/src/mpifx_recv.m4 @@ -5,7 +5,7 @@ dnl *** mpifx_recv dnl ************************************************************************ define(`_subroutine_mpifx_recv', `dnl -dnl $1: subroutien suffix +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)) diff --git a/src/mpifx_send.m4 b/src/mpifx_send.m4 index 5f60be7..d8bfd39 100644 --- a/src/mpifx_send.m4 +++ b/src/mpifx_send.m4 @@ -5,7 +5,7 @@ dnl *** mpifx_send dnl ************************************************************************ define(`_subroutine_mpifx_send', `dnl -dnl $1: subroutien suffix +dnl $1: subroutine 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)) From c7254fb3add8124f693f0ecd49d561d85dec106c Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Tue, 11 Aug 2015 10:09:39 +0100 Subject: [PATCH 13/72] Modified the project README. --- README.rst | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/README.rst b/README.rst index a118c0b..d5f42bb 100644 --- a/README.rst +++ b/README.rst @@ -5,15 +5,9 @@ The open source library `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. -A few essential communication routines are already covered. See the -documentation or the `online API documentation -`_ whether the routines -you need are there. If not, 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**. +It currently contains only a few routines so far, but if those happen to be the +ones you need, feel free to use this project (MPIFX is licensed under the +**simplified BSD license**). -Information about installation and usage of the library you find in the -documentation in the source or in the `online documentation -`_. Project status, current source code, -bugtracker etc. can be found on the `MPIFX project home page -`_. +If your desired MPI routine is not yet wrapped up, feel free to contribute to +the project to include the target functionality. From cd06a076f21994afbcb591a0e9b493e91545588f Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Tue, 11 Aug 2015 12:28:57 +0100 Subject: [PATCH 14/72] Missing implicit none. --- test/test_bcast.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/test_bcast.f90 b/test/test_bcast.f90 index 16ed6e0..b83a894 100644 --- a/test/test_bcast.f90 +++ b/test/test_bcast.f90 @@ -1,6 +1,7 @@ program test_bcast use libmpifx_module - + implicit none + integer, parameter :: dp = kind(1.0d0) integer, parameter :: sp = kind(1.0) From 72cf7e9ce7fc9d42a7705f8918086a19911b33b9 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sun, 16 Aug 2015 17:40:44 +0100 Subject: [PATCH 15/72] Missing implicit none. --- src/mpifx_common.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/mpifx_common.F90 b/src/mpifx_common.F90 index 8dd2333..f909307 100644 --- a/src/mpifx_common.F90 +++ b/src/mpifx_common.F90 @@ -6,6 +6,8 @@ module mpifx_common_module use mpi use mpifx_helper_module use mpifx_comm_module + implicit none + public end module mpifx_common_module From 6965afb4e26df1838baf0a920d356740af701329 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 13 Sep 2017 14:27:29 +0200 Subject: [PATCH 16/72] Modify makefile to enable building in separate directory --- src/Makefile.lib | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Makefile.lib b/src/Makefile.lib index ad1478b..0d7a514 100644 --- a/src/Makefile.lib +++ b/src/Makefile.lib @@ -2,13 +2,14 @@ # # Library makefile # +# Compiles and links mpifx in the current directory. +# # 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. You may also use the -D option to define macros (e.g. DEBUG) +# M4OPT: Options for the M4 macro processor. +# SRCDIR: Folder where source files can be found # ############################################################################### @@ -17,16 +18,18 @@ TARGETLIB = libmpifx.a +vpath % $(SRCDIR) + .PHONY: all all: $(TARGETLIB) -include Makefile.dep +include $(SRCDIR)/Makefile.dep $(TARGETLIB): $(libmpifx.o) ar r $@ $^ %.f90: %.F90 - $(M4) $(M4OPT) $< > $@ + $(M4) -I$(SRCDIR) $(M4OPT) $< > $@ %.o: %.f90 $(FXX) $(FXXOPT) -c $< @@ -40,7 +43,6 @@ distclean: clean rm -f *.mod rm -f $(TARGETLIB) - ### Local Variables: ### mode:makefile ### End: From 4368dca5cbb1906b60b1cb12128de07c7e333c3e Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sat, 18 Nov 2017 13:44:16 +0000 Subject: [PATCH 17/72] Changed URLs to github Also removed reference to online documentation generated from sphinx documents (should use readthedocs for this). --- README.rst | 2 +- doc/sphinx/about.rst | 8 ++++---- doc/sphinx/installing.rst | 5 ++--- doc/sphinx/routines.rst | 5 +---- doc/sphinx/using.rst | 2 +- 5 files changed, 9 insertions(+), 13 deletions(-) diff --git a/README.rst b/README.rst index d5f42bb..d60169e 100644 --- a/README.rst +++ b/README.rst @@ -1,7 +1,7 @@ MPIFX - Modern Fortran Interface for MPI ======================================== -The open source library `MPIFX `_ is +The open source library `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. diff --git a/doc/sphinx/about.rst b/doc/sphinx/about.rst index 8e05b92..7845b78 100644 --- a/doc/sphinx/about.rst +++ b/doc/sphinx/about.rst @@ -1,9 +1,9 @@ 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. +`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:: @@ -38,4 +38,4 @@ 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 `_. +details see the `project page `_. diff --git a/doc/sphinx/installing.rst b/doc/sphinx/installing.rst index 6abe4c7..c134274 100644 --- a/doc/sphinx/installing.rst +++ b/doc/sphinx/installing.rst @@ -9,14 +9,13 @@ In order to compile MPIFX, you need following prerequisites: * GNU Make. -There are basically two different ways of invoking the library into your -project: +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 in details. +Both are described below. Precompiling the library diff --git a/doc/sphinx/routines.rst b/doc/sphinx/routines.rst index 9d87f31..19d9a21 100644 --- a/doc/sphinx/routines.rst +++ b/doc/sphinx/routines.rst @@ -4,7 +4,4 @@ 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) or watch them in the `Online API -documentation -`_. Look for -the detailed descriptions of the interfaces for examples. +(see folder `doc/doxygen/` in the source tree) or sphinx. diff --git a/doc/sphinx/using.rst b/doc/sphinx/using.rst index c11f6d2..48b8a37 100644 --- a/doc/sphinx/using.rst +++ b/doc/sphinx/using.rst @@ -1,7 +1,7 @@ Using MPIFX =========== -Before you can use the MPIFX routines, you need basically the following steps. +Before you can use the MPIFX routines you need the following steps: #. Use the module `libmpifx_module` in your routines. From 27f231a236a0d023324b783ed30afce0808f7786 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Mon, 4 Dec 2017 12:02:26 +0000 Subject: [PATCH 18/72] Update Makefile.lib Minor comment changes --- src/Makefile.lib | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Makefile.lib b/src/Makefile.lib index 0d7a514..a496985 100644 --- a/src/Makefile.lib +++ b/src/Makefile.lib @@ -4,12 +4,12 @@ # # Compiles and links mpifx in the current directory. # -# Needs following variables: +# Needs the following variables: # FXX: Fortran 2003 compiler # FXXOPT: Options for the Fortran 2003 compiler # M4: M4 macro processor # M4OPT: Options for the M4 macro processor. -# SRCDIR: Folder where source files can be found +# SRCDIR: Folder where source files are located # ############################################################################### From 1ff5a4665b11e243f7fd461c02eddc489fea9e9e Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Mon, 4 Dec 2017 17:35:32 +0000 Subject: [PATCH 19/72] Fixed SRC path use for the test makefile --- test/GNUmakefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/GNUmakefile b/test/GNUmakefile index 70e8b92..bedfde6 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -43,11 +43,11 @@ include Makefile.targets .PHONY: clean realclean clean: - $(MAKE) -C $(SRCDIR) -f Makefile.lib clean + $(MAKE) SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib clean rm -f *.mod *.o _* distclean: clean - $(MAKE) -C $(SRCDIR) -f Makefile.lib distclean + $(MAKE) SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib distclean rm -f $(TARGETS) @@ -64,4 +64,4 @@ _FORCED_SUBMAKE_: FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ M4="$(M4)" M4OPT="$(M4OPT)" \ - -C $(SRCDIR) -f Makefile.lib + SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib From c0d0be92c29058dd3a71fd43ce33919ea4bf4bbd Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Mon, 4 Dec 2017 17:35:49 +0000 Subject: [PATCH 20/72] Minor comment change --- make.arch.template | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/make.arch.template b/make.arch.template index 229eca3..097ac7b 100644 --- a/make.arch.template +++ b/make.arch.template @@ -5,7 +5,7 @@ # Fortran 2003 compiler FXX = mpif90 -# Fortran compiler otions +# Fortran compiler options FXXOPT = -assume realloc_lhs -stand f03 -warn # Linker From 12cf6b694ff7cd0b083260f09c694257314759d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 26 Dec 2017 17:39:02 +0100 Subject: [PATCH 21/72] Make minor cosmetic changes --- LICENSE | 2 +- README.rst | 2 +- make.arch.template | 3 ++- src/mpifx.fypp | 24 ++++++++++++------------ src/mpifx_allgather.fpp | 16 ++++++++-------- src/mpifx_allreduce.fpp | 8 ++++---- src/mpifx_bcast.fpp | 2 +- src/mpifx_gather.fpp | 16 ++++++++-------- src/mpifx_helper.fpp | 22 +++++++++++----------- src/mpifx_recv.fpp | 2 +- src/mpifx_reduce.fpp | 6 +++--- src/mpifx_scatter.fpp | 18 +++++++++--------- src/mpifx_send.fpp | 4 ++-- 13 files changed, 63 insertions(+), 62 deletions(-) diff --git a/LICENSE b/LICENSE index a645313..1af00a5 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Bálint Aradi +Copyright (c) 2018, Bálint Aradi All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/README.rst b/README.rst index a118c0b..7ea2f8f 100644 --- a/README.rst +++ b/README.rst @@ -1,7 +1,7 @@ MPIFX - Modern Fortran Interface for MPI ======================================== -The open source library `MPIFX `_ is +The open source library `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. diff --git a/make.arch.template b/make.arch.template index a6bcf26..5982ff2 100644 --- a/make.arch.template +++ b/make.arch.template @@ -6,7 +6,7 @@ FXX = mpif90 # Fortran compiler otions -FXXOPT = -assume realloc_lhs -stand f03 -warn +FXXOPT = -std=f2008 # Linker LN = $(FXX) @@ -15,6 +15,7 @@ LN = $(FXX) LNOPT = # FYPP interpreter +# (see https://github.com/aradi/fypp if not installed in your system yet) FYPP = fypp # FYPP interpreter options (e.g. -DDEBUG for debug mode) diff --git a/src/mpifx.fypp b/src/mpifx.fypp index 4377386..eb708c7 100644 --- a/src/mpifx.fypp +++ b/src/mpifx.fypp @@ -39,34 +39,34 @@ #: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 +#! 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) +#:def DEBUG_CODE(code) #:if DEBUG > 0 $:code #:endif -#:enddef debug_code +#:enddef DEBUG_CODE #! Asserts the validity of a condition. #! #! cond: Condition #! -#:def ensure(cond) -#:call debug_code -if (.not. (${cond}$)) then - call ensure_failed("${_FILE_}$", ${_LINE_}$) +#:def ASSERT(COND) +#:call DEBUG_CODE +if (.not. (${COND}$)) then + call assert_failed("${_FILE_}$", ${_LINE_}$) end if #:endcall -#:enddef ensure +#:enddef ASSERT #:endmute diff --git a/src/mpifx_allgather.fpp b/src/mpifx_allgather.fpp index 159590a..893d2fa 100644 --- a/src/mpifx_allgather.fpp +++ b/src/mpifx_allgather.fpp @@ -104,10 +104,10 @@ contains type(mpifx_comm), intent(in) :: mycomm !> Quantity to be sent for gathering. - ${TYPE}$, intent(in) :: send${ranksuffix(RANK)}$ + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ !> Received data. - ${TYPE}$, intent(out) :: recv${ranksuffix(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ !> Error code on exit. integer, intent(out), optional :: error @@ -117,8 +117,8 @@ contains #:set SIZE = 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ensure (size(recv) == ${SIZE}$ * mycomm%size) - @:ensure (size(recv, dim=${RANK}$) == size(send, dim=${RANK}$) * mycomm%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) @@ -143,10 +143,10 @@ contains type(mpifx_comm), intent(in) :: mycomm !> Quantity to be sent for gathering. - ${TYPE}$, intent(in) :: send${ranksuffix(RANK)}$ + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ !> Received data. - ${TYPE}$, intent(out) :: recv${ranksuffix(RANK + 1)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK + 1)}$ !> Error code on exit. integer, intent(out), optional :: error @@ -156,8 +156,8 @@ contains #:set SIZE = '1' if RANK == 0 else 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ensure (size(recv) == ${SIZE}$ * mycomm%size) - @:ensure (size(recv, dim=${RANK + 1}$) == mycomm%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) diff --git a/src/mpifx_allreduce.fpp b/src/mpifx_allreduce.fpp index 847486e..c3e30c8 100644 --- a/src/mpifx_allreduce.fpp +++ b/src/mpifx_allreduce.fpp @@ -113,10 +113,10 @@ contains type(mpifx_comm), intent(in) :: mycomm !> Quantity to be reduced. - ${TYPE}$, intent(in) :: orig${ranksuffix(RANK)}$ + ${TYPE}$, intent(in) :: orig${RANKSUFFIX(RANK)}$ !> Contains result on exit. - ${TYPE}$, intent(inout) :: reduced${ranksuffix(RANK)}$ + ${TYPE}$, intent(inout) :: reduced${RANKSUFFIX(RANK)}$ !> Reduction operator integer, intent(in) :: reductionop @@ -127,7 +127,7 @@ contains integer :: error0 #:if RANK > 0 - @:ensure (size(orig) == size(reduced)) + @:ASSERT(size(orig) == size(reduced)) #:endif #:set SIZE = '1' if RANK == 0 else 'size(orig)' @@ -155,7 +155,7 @@ contains type(mpifx_comm), intent(in) :: mycomm !> Quantity to be reduced on input, reduced on exit. - ${TYPE}$, intent(inout) :: origreduced${ranksuffix(RANK)}$ + ${TYPE}$, intent(inout) :: origreduced${RANKSUFFIX(RANK)}$ !> Reduction operator. integer, intent(in) :: reductionop diff --git a/src/mpifx_bcast.fpp b/src/mpifx_bcast.fpp index 489e7cb..6ce66d4 100644 --- a/src/mpifx_bcast.fpp +++ b/src/mpifx_bcast.fpp @@ -59,7 +59,7 @@ contains type(mpifx_comm), intent(in) :: mycomm !> Msg to be broadcasted on root and received on non-root nodes. - ${TYPE}$ :: msg${ranksuffix(RANK)}$ + ${TYPE}$ :: msg${RANKSUFFIX(RANK)}$ !> Root node for the broadcast (default: mycomm%masterrank). integer, intent(in), optional :: root diff --git a/src/mpifx_gather.fpp b/src/mpifx_gather.fpp index f3e037e..98593c2 100644 --- a/src/mpifx_gather.fpp +++ b/src/mpifx_gather.fpp @@ -117,8 +117,8 @@ contains !! 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)}$ + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ integer, intent(in), optional :: root integer, intent(out), optional :: error @@ -127,8 +127,8 @@ contains #:set SIZE = 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ensure (.not. mycomm%master .or. size(recv) == size(send) * mycomm%size) - @:ensure (.not. mycomm%master .or.& + @:ASSERT(.not. mycomm%master .or. size(recv) == size(send) * mycomm%size) + @:ASSERT(.not. mycomm%master .or.& & size(recv, dim=${RANK}$) == size(send, dim=${RANK}$) * mycomm%size) call getoptarg(mycomm%masterrank, root0, root) @@ -155,8 +155,8 @@ contains !! 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)}$ + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK + 1)}$ integer, intent(in), optional :: root integer, intent(out), optional :: error @@ -165,8 +165,8 @@ contains #:set SIZE = '1' if RANK == 0 else 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ensure (.not. mycomm%master .or. size(recv) == ${SIZE}$ * mycomm%size) - @:ensure (.not. mycomm%master .or. size(recv, dim=${RANK + 1}$) == mycomm%size) + @:ASSERT(.not. mycomm%master .or. size(recv) == ${SIZE}$ * mycomm%size) + @:ASSERT(.not. mycomm%master .or. size(recv, dim=${RANK + 1}$) == mycomm%size) call getoptarg(mycomm%masterrank, root0, root) call mpi_gather(send, ${SIZE}$, ${MPITYPE}$, recv, ${SIZE}$, ${MPITYPE}$, root0, mycomm%id,& diff --git a/src/mpifx_helper.fpp b/src/mpifx_helper.fpp index f0e5206..98e826b 100644 --- a/src/mpifx_helper.fpp +++ b/src/mpifx_helper.fpp @@ -9,12 +9,12 @@ module mpifx_helper_module implicit none private - public :: DEFAULT_TAG, sp, dp - public :: handle_errorflag, ensure_failed + public :: default_tag, sp, dp + public :: handle_errorflag, assert_failed public :: getoptarg, setoptarg !> Default tag - integer, parameter :: DEFAULT_TAG = 0 + integer, parameter :: default_tag = 0 !> Single precision kind. integer, parameter :: sp = kind(1.0) @@ -78,9 +78,9 @@ contains end subroutine handle_errorflag - !> Stops code signalizing a failed ensure condition + !> Stops code signalizing a failed assert condition !! - subroutine ensure_failed(file, line) + subroutine assert_failed(file, line) character(*), intent(in) :: file integer, intent(in) :: line @@ -95,7 +95,7 @@ contains stop 1 end if - end subroutine ensure_failed + end subroutine assert_failed #:def getoptarg_template(SUFFIX, TYPE, RANK) @@ -103,9 +103,9 @@ contains #: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)}$ + ${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 @@ -123,8 +123,8 @@ contains #:assert RANK >= 0 subroutine setoptarg_${SUFFIX}$(curval, optval) - ${TYPE}$, intent(in) :: curval${ranksuffix(RANK)}$ - ${TYPE}$, intent(out), optional :: optval${ranksuffix(RANK)}$ + ${TYPE}$, intent(in) :: curval${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out), optional :: optval${RANKSUFFIX(RANK)}$ if (present(optval)) then optval = curval diff --git a/src/mpifx_recv.fpp b/src/mpifx_recv.fpp index d63a2d3..fd91f23 100644 --- a/src/mpifx_recv.fpp +++ b/src/mpifx_recv.fpp @@ -71,7 +71,7 @@ contains !! subroutine mpifx_recv_${SUFFIX}$(mycomm, msg, source, tag, status, error) type(mpifx_comm), intent(in) :: mycomm - ${TYPE}$, intent(out) :: msg${ranksuffix(RANK)}$ + ${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 diff --git a/src/mpifx_reduce.fpp b/src/mpifx_reduce.fpp index 83c4820..d2f3ff1 100644 --- a/src/mpifx_reduce.fpp +++ b/src/mpifx_reduce.fpp @@ -114,8 +114,8 @@ contains !! 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)}$ + ${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 @@ -149,7 +149,7 @@ contains !! subroutine mpifx_reduceip_${SUFFIX}$(mycomm, origred, reduceop, root, error) type(mpifx_comm), intent(in) :: mycomm - ${TYPE}$, intent(inout) :: origred${ranksuffix(RANK)}$ + ${TYPE}$, intent(inout) :: origred${RANKSUFFIX(RANK)}$ integer, intent(in) :: reduceop integer, intent(in), optional :: root integer, intent(out), optional :: error diff --git a/src/mpifx_scatter.fpp b/src/mpifx_scatter.fpp index 563fbb5..5e02962 100644 --- a/src/mpifx_scatter.fpp +++ b/src/mpifx_scatter.fpp @@ -106,8 +106,8 @@ contains !! 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)}$ + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK)}$ integer, intent(in), optional :: root integer, intent(out), optional :: error @@ -116,8 +116,8 @@ contains #:set SIZE = 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ensure (.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) - @:ensure (.not. mycomm%master& + @:ASSERT(.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) + @:ASSERT(.not. mycomm%master& & .or. size(send, dim=${RANK}$) == size(recv, dim=${RANK}$) * mycomm%size) call getoptarg(mycomm%masterrank, root0, root) @@ -144,8 +144,8 @@ contains !! 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)}$ + ${TYPE}$, intent(in) :: send${RANKSUFFIX(RANK)}$ + ${TYPE}$, intent(out) :: recv${RANKSUFFIX(RANK - 1)}$ integer, intent(in), optional :: root integer, intent(out), optional :: error @@ -154,10 +154,10 @@ contains #:set SIZE = '1' if RANK == 1 else 'size(recv)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ensure (.not. mycomm%master .or. size(send) == ${SIZE}$ * mycomm%size) - @:ensure (.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%size) + @:ASSERT(.not. mycomm%master .or. size(send) == ${SIZE}$ * mycomm%size) + @:ASSERT(.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%size) #:if HASLENGTH - @:ensure (.not. mycomm%master .or. len(send) == len(recv)) + @:ASSERT(.not. mycomm%master .or. len(send) == len(recv)) #:endif call getoptarg(mycomm%masterrank, root0, root) diff --git a/src/mpifx_send.fpp b/src/mpifx_send.fpp index 2b8f698..32c8f46 100644 --- a/src/mpifx_send.fpp +++ b/src/mpifx_send.fpp @@ -68,7 +68,7 @@ contains !! subroutine mpifx_send_${SUFFIX}$(mycomm, msg, dest, tag, error) type(mpifx_comm), intent(in) :: mycomm - ${TYPE}$, intent(in) :: msg${ranksuffix(RANK)}$ + ${TYPE}$, intent(in) :: msg${RANKSUFFIX(RANK)}$ integer, intent(in) :: dest integer, intent(in), optional :: tag integer, intent(out), optional :: error @@ -78,7 +78,7 @@ contains #: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 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) From b9d19cbae04b97224156936c76691df053e71308 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 26 Dec 2017 22:20:48 +0100 Subject: [PATCH 22/72] Refactor build framework --- .gitignore | 2 + README.rst | 46 +- external/fypp/LICENSE | 24 + external/fypp/README.rst | 232 +++ external/fypp/fypp | 1687 ++++++++++++++------- src/Makefile.lib => lib/make.build | 16 +- src/Makefile.dep => lib/make.deps | 0 {src => lib}/module.fpp | 0 {src => lib}/mpifx.fypp | 0 {src => lib}/mpifx_abort.fpp | 0 {src => lib}/mpifx_allgather.fpp | 0 {src => lib}/mpifx_allreduce.fpp | 0 {src => lib}/mpifx_barrier.fpp | 0 {src => lib}/mpifx_bcast.fpp | 0 {src => lib}/mpifx_comm.fpp | 0 {src => lib}/mpifx_common.fpp | 0 {src => lib}/mpifx_constants.fpp | 0 {src => lib}/mpifx_finalize.fpp | 0 {src => lib}/mpifx_gather.fpp | 0 {src => lib}/mpifx_get_processor_name.fpp | 0 {src => lib}/mpifx_helper.fpp | 0 {src => lib}/mpifx_init.fpp | 0 {src => lib}/mpifx_recv.fpp | 0 {src => lib}/mpifx_reduce.fpp | 0 {src => lib}/mpifx_scatter.fpp | 0 {src => lib}/mpifx_send.fpp | 0 make.arch.template | 15 +- makefile | 32 + src/GNUmakefile | 25 - test/GNUmakefile | 70 - test/Makefile.targets | 23 - test/make.build | 73 + test/{Makefile.dep => make.deps} | 0 33 files changed, 1552 insertions(+), 693 deletions(-) create mode 100644 external/fypp/LICENSE create mode 100644 external/fypp/README.rst rename src/Makefile.lib => lib/make.build (84%) rename src/Makefile.dep => lib/make.deps (100%) rename {src => lib}/module.fpp (100%) rename {src => lib}/mpifx.fypp (100%) rename {src => lib}/mpifx_abort.fpp (100%) rename {src => lib}/mpifx_allgather.fpp (100%) rename {src => lib}/mpifx_allreduce.fpp (100%) rename {src => lib}/mpifx_barrier.fpp (100%) rename {src => lib}/mpifx_bcast.fpp (100%) rename {src => lib}/mpifx_comm.fpp (100%) rename {src => lib}/mpifx_common.fpp (100%) rename {src => lib}/mpifx_constants.fpp (100%) rename {src => lib}/mpifx_finalize.fpp (100%) rename {src => lib}/mpifx_gather.fpp (100%) rename {src => lib}/mpifx_get_processor_name.fpp (100%) rename {src => lib}/mpifx_helper.fpp (100%) rename {src => lib}/mpifx_init.fpp (100%) rename {src => lib}/mpifx_recv.fpp (100%) rename {src => lib}/mpifx_reduce.fpp (100%) rename {src => lib}/mpifx_scatter.fpp (100%) rename {src => lib}/mpifx_send.fpp (100%) create mode 100644 makefile delete mode 100644 src/GNUmakefile delete mode 100644 test/GNUmakefile delete mode 100644 test/Makefile.targets create mode 100644 test/make.build rename test/{Makefile.dep => make.deps} (100%) diff --git a/.gitignore b/.gitignore index 91cd443..bd31fc7 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,5 @@ *.mod make.arch doc/doxygen/_build +_build +_install diff --git a/README.rst b/README.rst index d60169e..6ed24c5 100644 --- a/README.rst +++ b/README.rst @@ -1,13 +1,53 @@ +**************************************** MPIFX - Modern Fortran Interface for MPI -======================================== +**************************************** The open source library `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. It currently contains only a few routines so far, but if those happen to be the -ones you need, feel free to use this project (MPIFX is licensed under the -**simplified BSD license**). +ones you need, feel free to use this project. MPIFX is licensed under the +**simplified BSD license**. If your desired MPI routine is not yet wrapped up, feel free to contribute to the project to include the target functionality. + + +INSTALL +======= + +Stand-alone building +-------------------- + +#. Make a copy of the file `make.arch.template` as `make.arch`:: + + cp make.arch.template make.arch + +#. Configure any settings in `make.arch` in order to adapt it to your + environment. + +#. Issue :: + + make + + in order to build and library and :: + + make install + + in order to install it. + +#. You may build the examples in the `test/` subfolder with :: + + make test + + + +Build the library as part of a build process +-------------------------------------------- + +You may build the library on-the-fly during the build of your program. Invoke +the library makefile `lib/make.build` during your build process from the folder +where you wish to build the library. Make sure to pass the necessary +make-variables (as documented in the library makfile). See the `makefile` in +this folder for an example how to invoke the library makefile. diff --git a/external/fypp/LICENSE b/external/fypp/LICENSE new file mode 100644 index 0000000..d64971f --- /dev/null +++ b/external/fypp/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2016-2017 Bálint Aradi, Universität Bremen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. 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/external/fypp/README.rst b/external/fypp/README.rst new file mode 100644 index 0000000..2ccd6f4 --- /dev/null +++ b/external/fypp/README.rst @@ -0,0 +1,232 @@ +********************************************* +Fypp — Python powered Fortran metaprogramming +********************************************* + +.. image:: https://travis-ci.org/aradi/fypp.svg?branch=develop + :target: https://travis-ci.org/aradi/fypp + +Fypp is a Python powered preprocessor. It can be used for any programming +languages but its primary aim is to offer a Fortran preprocessor, which helps to +extend Fortran with condititional compiling and template metaprogramming +capabilities. Instead of introducing its own expression syntax, it uses Python +expressions in its preprocessor directives, offering the consistency and +versatility of Python when formulating metaprogramming tasks. It puts strong +emphasis on robustness and on neat integration into developing toolchains. + +The project is `hosted on github `_. + +`Detailed DOCUMENTATION `_ is available on +`readthedocs.org `_. + +Fypp is released under the *BSD 2-clause license*. + + +Main features +============= + +* Definition, evaluation and removal of variables:: + + #:if DEBUG > 0 + print *, "Some debug information" + #:endif + + #:set LOGLEVEL = 2 + print *, "LOGLEVEL: ${LOGLEVEL}$" + + #:del LOGLEVEL + +* Macro definitions and macro calls:: + + #:def assertTrue(cond) + #:if DEBUG > 0 + if (.not. ${cond}$) then + print *, "Assert failed in file ${_FILE_}$, line ${_LINE_}$" + error stop + end if + #:endif + #:enddef assertTrue + + ! Invoked via direct call (argument needs no quotation) + @:assertTrue(size(myArray) > 0) + + ! Invoked as Python expression (argument needs quotation) + $:assertTrue('size(myArray) > 0') + +* Conditional output:: + + program test + #:if defined('WITH_MPI') + use mpi + #:elif defined('WITH_OPENMP') + use openmp + #:else + use serial + #:endif + +* Iterated output (e.g. for generating Fortran templates):: + + interface myfunc + #:for dtype in ['real', 'dreal', 'complex', 'dcomplex'] + module procedure myfunc_${dtype}$ + #:endfor + end interface myfunc + +* Inline directives:: + + logical, parameter :: hasMpi = #{if defined('MPI')}# .true. #{else}# .false. #{endif}# + +* Insertion of arbitrary Python expressions:: + + character(*), parameter :: comp_date = "${time.strftime('%Y-%m-%d')}$" + +* Inclusion of files during preprocessing:: + + #:include "macrodefs.fypp" + +* Using Fortran-style continutation lines in preprocessor directives:: + + #:if var1 > var2 & + & or var2 > var4 + print *, "Doing something here" + #:endif + +* Passing (unquoted) multiline string arguments to callables:: + + #! Callable needs only string argument + #:def debug_code(code) + #:if DEBUG > 0 + $:code + #:endif + #:enddef debug_code + + #! Pass code block as first positional argument + #:call debug_code + if (size(array) > 100) then + print *, "DEBUG: spuriously large array" + end if + #:endcall debug_code + + #! Callable needs also non-string argument types + #:def repeat_code(code, repeat) + #:for ind in range(repeat) + $:code + #:endfor + #:enddef repeat_code + + #! Pass code block as positional argument and 3 as keyword argument "repeat" + #:call repeat_code(repeat=3) + this will be repeated 3 times + #:endcall repeat_code + +* Preprocessor comments:: + + #! This will not show up in the output + #! Also the newline characters at the end of the lines will be suppressed + +* Suppressing the preprocessor output in selected regions:: + + #! Definitions are read, but no output (e.g. newlines) will be produced + #:mute + #:include "macrodefs.fypp" + #:endmute + +* Explicit request for stopping the preprocessor:: + + #:if DEBUGLEVEL < 0 + #:stop 'Negative debug level not allowed!' + #:endif + +* Easy check for macro parameter sanity:: + + #:def mymacro(RANK) + #! Macro only works for RANK 1 and above + #:assert RANK > 0 + : + #:enddef mymacro + +* Line numbering directives in output:: + + program test + #:if defined('MPI') + use mpi + #:endif + : + + transformed to :: + + # 1 "test.fypp" 1 + program test + # 3 "test.fypp" + use mpi + # 5 "test.fypp" + : + + when variable ``MPI`` is defined and Fypp was instructed to generate line + markers. + +* Automatic folding of generated lines exceeding line length limit + + +Installing +========== + +Fypp needs a working Python interpreter. It is compatible with Python 2 (version +2.6 and above) and Python 3 (all versions). + +Automatic install +----------------- + +Use Pythons command line installer ``pip`` in order to download the stable +release from the `Fypp page on PyPI `_ and +install it on your system:: + + pip install fypp + +This installs both, the command line tool ``fypp`` and the Python module +``fypp.py``. Latter you can import if you want to access the functionality of +Fypp directly from within your Python scripts. + + +Manual install +-------------- + +For a manual install, you can download the source code of the **stable** +releases from the `Fypp project website +`_. + +If you wish to obtain the latest **development** version, clone the projects +repository:: + + git clone https://github.com/aradi/fypp.git + +and check out the `master` branch. + +The command line tool is a single stand-alone script. You can run it directly +from the source folder :: + + FYPP_SOURCE_FOLDER/bin/fypp + +or after copying it from the `bin` folder to any location listed in your `PATH` +environment variable, by just issuing :: + + fypp + +The python module ``fypp.py`` can be found in ``FYP_SOURCE_FOLDER/src``. + + +Running +======= + +The Fypp command line tool reads a file, preprocesses it and writes it to +another file, so you would typically invoke it like:: + + fypp source.fpp source.f90 + +which would process `source.fpp` and write the result to `source.f90`. If +input and output files are not specified, information is read from stdin and +written to stdout. + +The behavior of Fypp can be influenced with various command line options. A +summary of all command line options can be obtained by:: + + fypp -h diff --git a/external/fypp/fypp b/external/fypp/fypp index 6fd0ad7..a2c7965 100755 --- a/external/fypp/fypp +++ b/external/fypp/fypp @@ -4,7 +4,7 @@ # # fypp -- Python powered Fortran preprocessor # -# Copyright (c) 2016, Bálint Aradi +# Copyright (c) 2017 Bálint Aradi, Universität Bremen # # All rights reserved. # @@ -31,29 +31,15 @@ # ################################################################################ -'''The functionality of the Fypp preprocessor is mainly realized by -using following classes: +'''For using the functionality of the Fypp preprocessor from within +Python, one usually interacts with the following two classes: -* `Parser`_: Reads a source file, does basic syntax checking and generates - events. - -* `Builder`_: Builds a tree representation of the source file by - receiving events. Does additional syntax checking. - -* `Renderer`_: Renders a tree built by the builder. - -* `Evaluator`_: Evaluates Python expressions in a designated environment. It is - used by `Renderer`_ when rendering eval directives. - -* `Processor`_: Connects `Parser`_, `Builder`_, `Renderer`_ and `Evaluator`_ - with each other and returns for a given input the preprocessed output. - -* `Fypp`_: The actual Fypp preprocessor. It initializes and drives - `Processor`_. +* `Fypp`_: The actual Fypp preprocessor. It returns for a given input + the preprocessed output. * `FyppOptions`_: Contains customizable settings controling the behaviour of `Fypp`_. Alternatively, the function `get_option_parser()`_ can be used to - obtain an argument parser, which can create settings based on command line + obtain an option parser, which can create settings based on command line arguments. If processing stops prematurely, an instance of one of the following @@ -63,29 +49,26 @@ subclasses of `FyppError`_ is raised: * FyppStopRequest: Stop was triggered by an explicit request in the input (by a stop- or an assert-directive). - -Additional to those above an additional class is used for fine tuning: - -* `FortranLineFolder`_: Folds overlong lines by using Fortran continuation - lines. - ''' from __future__ import print_function import sys import types +import inspect import re import os import errno import time -from argparse import ArgumentParser +import optparse if sys.version_info[0] >= 3: import builtins else: import __builtin__ as builtins +# Prevent cluttering user directory with Python bytecode +sys.dont_write_bytecode = True -VERSION = '1.3-dev' +VERSION = '2.1.1' STDIN = '' @@ -97,50 +80,49 @@ ERROR_EXIT_CODE = 1 USER_ERROR_EXIT_CODE = 2 -_LINE_DIRECTIVES_PATTERN = r''' +_ALL_DIRECTIVES_PATTERN = r''' # comment block -(?P(?:^[ \t]*\#!.*\n)+) -| -# line control directive (with optional continuation lines) -^[ \t]*\#:[ \t]*(?P\w+)[ \t]* -(?P.*?(?:&[ \t]*\n[ \t]*&.*?)*)?[ \t]*\n +(?:^[ \t]*\#!.*\n)+ | -# line eval directive (with optional continuation lines) -^[ \t]*\$:[ \t]*(?P.*?(?:&[ \t]*\n(?:[ \t]*&)?.*?)*)[ \t]*\n -| -# direct call directive (with optional continuation lines) -^[ \t]*@:[ \t]*(?P\w+)[ \t]* -(?P.*?(?:&[ \t]*\n[ \t]*&.*?)*)?[ \t]*\n -''' - -_INLINE_DIRECTIVES_PATTERN = r''' -# inline control directive -\#\{[ \t]*(?P\w+)[ \t]*(?P.*?)?[ \t]*\}\# +# line directive (with optional continuation lines) +^[ \t]*(?P[\#\$@]):[ \t]* +(?P.+?(?:&[ \t]*\n(?:[ \t]*&)?.*?)*)?[ \t]*\n | # inline eval directive -\$\{[ \t]*(?P.*?)[ \t]*\}\$ +(?P[$\#@])\{[ \t]*(?P.+?)?[ \t]*\}(?P=idirtype) ''' -_INLINE_DIRECTIVES_REGEXP = re.compile( - _INLINE_DIRECTIVES_PATTERN, re.VERBOSE | re.MULTILINE) - _ALL_DIRECTIVES_REGEXP = re.compile( - _LINE_DIRECTIVES_PATTERN + '|' + _INLINE_DIRECTIVES_PATTERN, - re.VERBOSE | re.MULTILINE) + _ALL_DIRECTIVES_PATTERN, re.VERBOSE | re.MULTILINE) + +_CONTROL_DIR_REGEXP = re.compile( + r'(?P[a-zA-Z_]\w*)[ \t]*(?:[ \t]+(?P[^ \t].*))?$') + +_DIRECT_CALL_REGEXP = re.compile( + r'(?P[a-zA-Z_][\w.]*)[ \t]*\((?P.+?)?\)$') + +_DIRECT_CALL_KWARG_REGEXP = re.compile( + r'(?:(?P[a-zA-Z_]\w*)\s*=(?=[^=]|$))?') _DEF_PARAM_REGEXP = re.compile( - r'^(?P\w+)\(\s*(?P(?:(?:\w+\s*,\s*)*(?:\w+)))?\s*\)$') + r'^(?P[a-zA-Z_]\w*)[ \t]*\(\s*(?P.+)?\s*\)$') + +_SIMPLE_CALLABLE_REGEXP = re.compile( + r'^(?P[a-zA-Z_][\w.]*)[ \t]*(?:\([ \t]*(?P.*)[ \t]*\))?$') + +_IDENTIFIER_NAME_REGEXP = re.compile(r'^(?P[a-zA-Z_]\w*)$') -_ENDDEF_PARAM_REGEXP = re.compile(r'^(?P\w+)?$') +_PREFIXED_IDENTIFIER_NAME_REGEXP = re.compile(r'^(?P[a-zA-Z_][\w.]*)$') -_CALL_PARAM_REGEXP = re.compile(r'^(?P\w+)$') +_SET_PARAM_REGEXP = re.compile( + r'^(?P(?:[(]\s*)?[a-zA-Z_]\w*(?:\s*,\s*[a-zA-Z_]\w*)*(?:\s*[)])?)\s*'\ + r'(?:=\s*(?P.*))?$') -_SETVAR_PARAM_REGEXP = re.compile( - r'^(?P(?:[(]\s*)?\w+(?:\s*,\s*\w+)*(?:\s*[)])?)'\ - r'(?:(?:(?:\s*=\s*)|\s+)(?P.*))?$') +_DEL_PARAM_REGEXP = re.compile( + r'^(?:[(]\s*)?[a-zA-Z_]\w*(?:\s*,\s*[a-zA-Z_]\w*)*(?:\s*[)])?$') _FOR_PARAM_REGEXP = re.compile( - r'^(?P\w+(\s*,\s*\w+)*)\s+in\s+(?P.+)$') + r'^(?P[a-zA-Z_]\w*(\s*,\s*[a-zA-Z_]\w*)*)\s+in\s+(?P.+)$') _INCLUDE_PARAM_REGEXP = re.compile(r'^(\'|")(?P.*?)\1$') @@ -148,16 +130,29 @@ _COMMENTLINE_REGEXP = re.compile(r'^[ \t]*!.*$') _CONTLINE_REGEXP = re.compile(r'&[ \t]*\n(?:[ \t]*&)?') -_UNESCAPE_REGEXP1 = re.compile(r'([$#])\\(\\*)([{:])') +_UNESCAPE_TEXT_REGEXP1 = re.compile(r'([$#@])\\(\\*)([{:])') -_UNESCAPE_REGEXP2 = re.compile(r'(\})\\(\\*)([$#])') +_UNESCAPE_TEXT_REGEXP2 = re.compile(r'(\})\\(\\*)([$#@])') -_UNESCAPE_REGEXP3 = re.compile(r'(@)\\(\\*)([:@])') +_INLINE_EVAL_REGION_REGEXP = re.compile(r'\${.*?}\$') _RESERVED_PREFIX = '__' -_RESERVED_NAMES = ('defined', 'setvar', 'getvar', '_LINE_', '_FILE_', - '_TIME_', '_DATE_') +_RESERVED_NAMES = set(['defined', 'setvar', 'getvar', 'delvar', 'globalvar', + '_LINE_', '_FILE_', '_THIS_FILE_', '_THIS_LINE_', + '_TIME_', '_DATE_']) + +_LINENUM_NEW_FILE = 1 + +_LINENUM_RETURN_TO_FILE = 2 + +_QUOTES_FORTRAN = '\'"' + +_OPENING_BRACKETS_FORTRAN = '{([' + +_CLOSING_BRACKETS_FORTRAN = '})]' + +_ARGUMENT_SPLIT_CHAR_FORTRAN = ',' class FyppError(Exception): @@ -167,7 +162,8 @@ class FyppError(Exception): msg (str): Error message. fname (str): File name. None (default) if file name is not available. span (tuple of int): Beginning and end line of the region where error - occured or None if not available. + occured or None if not available. If fname was not None, span must + not be None. cause (Exception): Contains the exception, which triggered this exception or None, if this exception is not masking any underlying one. (Emulates Python 3 exception chaining in a Python 2 compatible @@ -194,23 +190,20 @@ class FyppError(Exception): def __str__(self): - if self.cause is not None: - cause = str(self.cause) - else: - cause = '' - msg = [self.__class__.__name__, ':'] + msg = [self.__class__.__name__, ': '] if self.fname is not None: - msg.append(" file '" + self.fname + "'") - if self.span is not None: - if self.span[1] > self.span[0] + 1: - msg.append(', lines {}-{}'.format( - self.span[0] + 1, self.span[1])) - else: - msg.append(', line {}'.format(self.span[0] + 1)) + msg.append("file '" + self.fname + "'") + if self.span[1] > self.span[0] + 1: + msg.append(', lines {0}-{1}'.format( + self.span[0] + 1, self.span[1])) + else: + msg.append(', line {0}'.format(self.span[0] + 1)) msg.append('\n') if self.msg: msg.append(self.msg) - return ''.join(msg) + '\n' + cause + if self.cause is not None: + msg.append('\n' + str(self.cause)) + return ''.join(msg) class FyppFatalError(FyppError): @@ -314,8 +307,8 @@ class Parser: self._log_event('endinclude', span, filename=fname) - def handle_setvar(self, span, name, expr): - '''Called when parser encounters a setvar directive. + def handle_set(self, span, name, expr): + '''Called when parser encounters a set directive. It is a dummy method and should be overriden for actual use. @@ -325,7 +318,7 @@ class Parser: expr (str): String representation of the expression to be assigned to the variable. ''' - self._log_event('setvar', span, name=name, expression=expr) + self._log_event('set', span, name=name, expression=expr) def handle_def(self, span, name, args): @@ -336,7 +329,7 @@ class Parser: Args: span (tuple of int): Start and end line of the directive. name (str): Name of the macro to be defined. - args (list of str): Name of the macro arguments. + argexpr (str): String with argument definition (or None) ''' self._log_event('def', span, name=name, arguments=args) @@ -353,6 +346,18 @@ class Parser: self._log_event('enddef', span, name=name) + def handle_del(self, span, name): + '''Called when parser encounters a del directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the variable to delete. + ''' + self._log_event('del', span, name=name) + + def handle_if(self, span, cond): '''Called when parser encounters an if directive. @@ -424,38 +429,43 @@ class Parser: self._log_event('endfor', span) - def handle_call(self, span, macro): + def handle_call(self, span, name, argexpr): '''Called when parser encounters a call directive. It is a dummy method and should be overriden for actual use. Args: span (tuple of int): Start and end line of the directive. - macro (str): Macro to call. + name (str): Name of the callable to call + argexpr (str or None): Argument expression containing additional + arguments for the call. ''' - self._log_event('call', span, macro=macro) + self._log_event('call', span, name=name, argexpr=argexpr) - def handle_nextarg(self, span): + def handle_nextarg(self, span, name): '''Called when parser encounters a nextarg directive. It is a dummy method and should be overriden for actual use. Args: span (tuple of int): Start and end line of the directive. + name (str or None): Name of the argument following next or + None if it should be the next positional argument. ''' - self._log_event('nextarg', span) + self._log_event('nextarg', span, name=name) - def handle_endcall(self, span): + def handle_endcall(self, span, name): '''Called when parser encounters an endcall directive. It is a dummy method and should be overriden for actual use. Args: span (tuple of int): Start and end line of the directive. + name (str): Name found after the endcall directive. ''' - self._log_event('endcall', span) + self._log_event('endcall', span, name=name) def handle_eval(self, span, expr): @@ -471,6 +481,18 @@ class Parser: self._log_event('eval', span, expression=expr) + def handle_global(self, span, name): + '''Called when parser encounters a global directive. + + It is a dummy method and should be overriden for actual use. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the variable which should be made global. + ''' + self._log_event('global', span, name=name) + + def handle_text(self, span, txt): '''Called when parser finds text which must left unaltered. @@ -541,45 +563,49 @@ class Parser: @staticmethod def _log_event(event, span=(-1, -1), **params): - print('{}: {} --> {}'.format(event, span[0], span[1])) + print('{0}: {1} --> {2}'.format(event, span[0], span[1])) for parname, parvalue in params.items(): - print(' {}: ->|{}|<-'.format(parname, parvalue)) + print(' {0}: ->|{1}|<-'.format(parname, parvalue)) print() - def _parse(self, txt, linenr=0, linedirs=True): + def _parse(self, txt, linenr=0, directcall=False): pos = 0 - if linedirs: - regexp = _ALL_DIRECTIVES_REGEXP - else: - regexp = _INLINE_DIRECTIVES_REGEXP - for match in regexp.finditer(txt): - groups = match.groupdict() + for match in _ALL_DIRECTIVES_REGEXP.finditer(txt): start, end = match.span() if start > pos: endlinenr = linenr + txt.count('\n', pos, start) self._process_text(txt[pos:start], (linenr, endlinenr)) linenr = endlinenr endlinenr = linenr + txt.count('\n', start, end) - if linedirs and groups['ldirective'] is not None: - self._process_directive( - groups['ldirective'], groups['lparam'], - (linenr, endlinenr)) - elif linedirs and groups['lexpr'] is not None: - self._process_lexpreval(groups['lexpr'], (linenr, endlinenr)) - elif groups['idirective'] is not None: - self._process_directive(groups['idirective'], groups['param'], - (linenr, endlinenr)) - elif groups['iexpr'] is not None: - self._process_iexpreval(groups['iexpr'], (linenr, endlinenr)) - elif linedirs and groups['comment'] is not None: - self.handle_comment((linenr, endlinenr)) - elif linedirs and groups['macro'] is not None: - self._process_directcall( - groups['macro'], groups['macroparams'], (linenr, endlinenr)) + span = (linenr, endlinenr) + ldirtype, ldir, idirtype, idir = match.groups() + if directcall and (idirtype is None or idirtype != '$'): + msg = 'only inline eval directives allowed in direct calls' + raise FyppFatalError(msg, self._curfile, span) + elif idirtype is not None: + if idir is None: + msg = 'missing inline directive content' + raise FyppFatalError(msg, self._curfile, span) + dirtype = idirtype + content = idir + elif ldirtype is not None: + if ldir is None: + msg = 'missing line directive content' + raise FyppFatalError(msg, self._curfile, span) + dirtype = ldirtype + content = _CONTLINE_REGEXP.sub('', ldir) + else: + # Comment directive + dirtype = None + if dirtype == '$': + self.handle_eval(span, content) + elif dirtype == '#': + self._process_control_dir(content, span) + elif dirtype == '@': + self._process_direct_call(content, span) else: - msg = 'internal error: unknown matching pattern' - raise FyppFatalError(msg, self._curfile, (linenr, endlinenr)) + self.handle_comment(span) pos = end linenr = endlinenr if pos < len(txt): @@ -592,116 +618,153 @@ class Parser: self.handle_text(span, escaped_txt) - def _process_directive(self, directive, param, span): - param = _CONTLINE_REGEXP.sub('', param) + def _process_control_dir(self, content, span): + match = _CONTROL_DIR_REGEXP.match(content) + if not match: + msg = "invalid control directive content '{0}'".format(content) + raise FyppFatalError(msg, self._curfile, span) + directive, param = match.groups() if directive == 'if': + self._check_param_presence(True, 'if', param, span) self.handle_if(span, param) elif directive == 'else': - self._check_empty_param('else', param, span) + self._check_param_presence(False, 'else', param, span) self.handle_else(span) elif directive == 'elif': + self._check_param_presence(True, 'elif', param, span) self.handle_elif(span, param) elif directive == 'endif': - self._check_empty_param('endif', param, span) + self._check_param_presence(False, 'endif', param, span) self.handle_endif(span) elif directive == 'def': + self._check_param_presence(True, 'def', param, span) + self._check_not_inline_directive('def', span) self._process_def(param, span) elif directive == 'enddef': self._process_enddef(param, span) - elif directive == 'setvar' or directive == 'set': - self._process_setvar(param, span) + elif directive == 'set': + self._check_param_presence(True, 'set', param, span) + self._process_set(param, span) + elif directive == 'del': + self._check_param_presence(True, 'del', param, span) + self._process_del(param, span) elif directive == 'for': + self._check_param_presence(True, 'for', param, span) self._process_for(param, span) elif directive == 'endfor': - self._check_empty_param('endfor', param, span) + self._check_param_presence(False, 'endfor', param, span) self.handle_endfor(span) elif directive == 'call': + self._check_param_presence(True, 'call', param, span) self._process_call(param, span) elif directive == 'nextarg': - self._check_empty_param('nextcall', param, span) - self.handle_nextarg(span) + self._process_nextarg(param, span) elif directive == 'endcall': - self._check_empty_param('endcall', param, span) - self.handle_endcall(span) + self._process_endcall(param, span) elif directive == 'include': + self._check_param_presence(True, 'include', param, span) self._check_not_inline_directive('include', span) self._process_include(param, span) elif directive == 'mute': - self._check_empty_param('mute', param, span) + self._check_param_presence(False, 'mute', param, span) self._check_not_inline_directive('mute', span) self.handle_mute(span) elif directive == 'endmute': - self._check_empty_param('endmute', param, span) + self._check_param_presence(False, 'endmute', param, span) self._check_not_inline_directive('endmute', span) self.handle_endmute(span) elif directive == 'stop': + self._check_param_presence(True, 'stop', param, span) self._check_not_inline_directive('stop', span) self.handle_stop(span, param) elif directive == 'assert': + self._check_param_presence(True, 'assert', param, span) self._check_not_inline_directive('assert', span) self.handle_assert(span, param) + elif directive == 'global': + self._check_param_presence(True, 'global', param, span) + self._process_global(param, span) else: - msg = "unknown directive '{}'".format(directive) + msg = "unknown directive '{0}'".format(directive) raise FyppFatalError(msg, self._curfile, span) - def _process_lexpreval(self, expr, span): - expr = _CONTLINE_REGEXP.sub('', expr) - self.handle_eval(span, expr) + def _process_direct_call(self, callexpr, span): + match = _DIRECT_CALL_REGEXP.match(callexpr) + if not match: + msg = "invalid direct call expression" + raise FyppFatalError(msg, self._curfile, span) + callname = match.group('callname') + self.handle_call(span, callname, None) + callparams = match.group('callparams') + if callparams is None or not callparams.strip(): + args = [] + else: + try: + args = [arg.strip() for arg in _argsplit_fortran(callparams)] + except Exception as exc: + msg = 'unable to parse direct call argument' + raise FyppFatalError(msg, self._curfile, span, exc) + for arg in args: + match = _DIRECT_CALL_KWARG_REGEXP.match(arg) + argval = arg[match.end():].strip() + # Remove enclosing braces if present + if argval.startswith('{'): + argval = argval[1:-1] + keyword = match.group('kwname') + self.handle_nextarg(span, keyword) + self._parse(argval, linenr=span[0], directcall=True) + self.handle_endcall(span, callname) - def _process_iexpreval(self, expr, span): - self.handle_eval(span, expr) + def _process_def(self, param, span): + match = _DEF_PARAM_REGEXP.match(param) + if not match: + msg = "invalid macro definition '{0}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + name = match.group('name') + argexpr = match.group('args') + self.handle_def(span, name, argexpr) - def _process_directcall(self, macroname, macroparams, span): - macroparams = _CONTLINE_REGEXP.sub('', macroparams) - self._process_call(macroname, span) - args = [arg.strip() for arg in macroparams.split('@@')] - if len(args): - linenr = span[0] - self._parse(args[0], linenr=linenr, linedirs=False) - for arg in args[1:]: - self.handle_nextarg(span) - self._parse(arg, linenr=linenr, linedirs=False) - self.handle_endcall(span) + def _process_enddef(self, param, span): + if param is not None: + match = _IDENTIFIER_NAME_REGEXP.match(param) + if not match: + msg = "invalid enddef parameter '{0}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + param = match.group('name') + self.handle_enddef(span, param) - def _process_def(self, param, span): - match = _DEF_PARAM_REGEXP.search(param) + def _process_set(self, param, span): + match = _SET_PARAM_REGEXP.match(param) if not match: - msg = "invalid macro definition '{}'".format(param) + msg = "invalid variable assignment '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) - name = match.group('name') - argstr = match.group('args') - if argstr is None: - args = [] - else: - args = [s.strip() for s in argstr.split(',')] - self.handle_def(span, name, args) + self.handle_set(span, match.group('name'), match.group('expr')) - def _process_enddef(self, param, span): - match = _ENDDEF_PARAM_REGEXP.search(param) + def _process_global(self, param, span): + match = _DEL_PARAM_REGEXP.match(param) if not match: - msg = "invalid enddef parameter '{}'".format(param) + msg = "invalid variable specification '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) - name = match.group('name') - self.handle_enddef(span, name) + self.handle_global(span, param) - def _process_setvar(self, param, span): - match = _SETVAR_PARAM_REGEXP.search(param) + def _process_del(self, param, span): + match = _DEL_PARAM_REGEXP.match(param) if not match: - msg = "invalid variable assignment '{}'".format(param) + msg = "invalid variable specification '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) - self.handle_setvar(span, match.group('name'), match.group('expr')) + self.handle_del(span, param) def _process_for(self, param, span): - match = _FOR_PARAM_REGEXP.search(param) + match = _FOR_PARAM_REGEXP.match(param) if not match: - msg = "invalid for loop declaration '{}'".format(param) + msg = "invalid for loop declaration '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) loopexpr = match.group('loopexpr') loopvars = [s.strip() for s in loopexpr.split(',')] @@ -709,18 +772,38 @@ class Parser: def _process_call(self, param, span): - match = _CALL_PARAM_REGEXP.search(param) + match = _SIMPLE_CALLABLE_REGEXP.match(param) if not match: - msg = "invalid macro call '{}'".format(param) + msg = "invalid callable expression '{}'".format(param) raise FyppFatalError(msg, self._curfile, span) - name = match.group('name') - self.handle_call(span, name) + name, args = match.groups() + self.handle_call(span, name, args) + + + def _process_nextarg(self, param, span): + if param is not None: + match = _IDENTIFIER_NAME_REGEXP.match(param) + if not match: + msg = "invalid nextarg parameter '{0}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + param = match.group('name') + self.handle_nextarg(span, param) + + + def _process_endcall(self, param, span): + if param is not None: + match = _PREFIXED_IDENTIFIER_NAME_REGEXP.match(param) + if not match: + msg = "invalid endcall parameter '{0}'".format(param) + raise FyppFatalError(msg, self._curfile, span) + param = match.group('name') + self.handle_endcall(span, param) def _process_include(self, param, span): - match = _INCLUDE_PARAM_REGEXP.search(param) + match = _INCLUDE_PARAM_REGEXP.match(param) if not match: - msg = "invalid include file declaration '{}'".format(param) + msg = "invalid include file declaration '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) fname = match.group('fname') for incdir in [self._curdir] + self._includedirs: @@ -728,7 +811,7 @@ class Parser: if os.path.exists(fpath): break else: - msg = "include file '{}' not found".format(fname) + msg = "include file '{0}' not found".format(fname) raise FyppFatalError(msg, self._curfile, span) inpfp = _open_input_file(fpath) self._includefile(span, inpfp, fpath, os.path.dirname(fpath)) @@ -749,22 +832,25 @@ class Parser: self.handle_endmute(span) - def _check_empty_param(self, directive, param, span): - if param.strip(): - msg = 'superfluous data in {} directive'.format(directive) + def _check_param_presence(self, presence, directive, param, span): + if (param is not None) != presence: + if presence: + msg = 'missing data in {0} directive'.format(directive) + else: + msg = 'forbidden data in {0} directive'.format(directive) raise FyppFatalError(msg, self._curfile, span) + def _check_not_inline_directive(self, directive, span): if span[0] == span[1]: - msg = 'Inline form of {} directive not allowed'.format(directive) + msg = 'Inline form of {0} directive not allowed'.format(directive) raise FyppFatalError(msg, self._curfile, span) @staticmethod def _unescape(txt): - txt = _UNESCAPE_REGEXP1.sub(r'\1\2\3', txt) - txt = _UNESCAPE_REGEXP2.sub(r'\1\2\3', txt) - txt = _UNESCAPE_REGEXP3.sub(r'\1\2\3', txt) + txt = _UNESCAPE_TEXT_REGEXP1.sub(r'\1\2\3', txt) + txt = _UNESCAPE_TEXT_REGEXP2.sub(r'\1\2\3', txt) return txt @@ -830,23 +916,23 @@ class Builder: nprev_blocks = self._nr_prev_blocks.pop(-1) if len(self._open_blocks) > nprev_blocks: directive, fname, spans = self._open_blocks[-1][0:3] - msg = '{} directive in line {} still unclosed when reaching end '\ - 'of file'.format(directive, spans[0][0] + 1) - raise FyppFatalError(msg, self._curfile) + msg = '{0} directive still unclosed when reaching end of file'\ + .format(directive) + raise FyppFatalError(msg, self._curfile, spans[0]) block = self._open_blocks.pop(-1) directive, blockfname, spans = block[0:3] if directive != 'include': msg = 'internal error: last open block is not \'include\' when '\ - 'closing file \'{}\''.format(fname) + 'closing file \'{0}\''.format(fname) raise FyppFatalError(msg) if span != spans[0]: msg = 'internal error: span for include and endinclude differ ('\ - '{} vs {}'.format(span, spans[0]) + '{0} vs {1}'.format(span, spans[0]) raise FyppFatalError(msg) oldfname, _ = block[3:5] if fname != oldfname: msg = 'internal error: mismatching file name in close_file event'\ - " (expected: '{}', got: '{}')".format(oldfname, fname) + " (expected: '{0}', got: '{1}')".format(oldfname, fname) raise FyppFatalError(msg, fname) block = directive, blockfname, spans, fname, self._curnode self._curnode = self._path.pop(-1) @@ -950,17 +1036,17 @@ class Builder: self._curnode.append(block) - def handle_def(self, span, name, args): + def handle_def(self, span, name, argexpr): '''Should be called to signalize a def directive. Args: span (tuple of int): Start and end line of the directive. name (str): Name of the macro to be defined. - args (list of str): Name of the macro arguments. + argexpr (str): Macro argument definition or None ''' self._path.append(self._curnode) self._curnode = [] - defblock = ('def', self._curfile, [span], name, args, None) + defblock = ('def', self._curfile, [span], name, argexpr, None) self._open_blocks.append(defblock) @@ -976,66 +1062,91 @@ class Builder: block = self._open_blocks.pop(-1) directive, fname, spans = block[0:3] self._check_if_matches_last(directive, 'def', spans[-1], span, 'enddef') - defname, args, dummy = block[3:6] + defname, argexpr, dummy = block[3:6] if name is not None and name != defname: msg = "wrong name in enddef directive "\ - "(expected '{}', got '{}')".format(defname, name) + "(expected '{0}', got '{1}')".format(defname, name) raise FyppFatalError(msg, fname, span) spans.append(span) - block = (directive, fname, spans, defname, args, self._curnode) + block = (directive, fname, spans, defname, argexpr, self._curnode) self._curnode = self._path.pop(-1) self._curnode.append(block) - def handle_call(self, span, name): + def handle_call(self, span, name, argexpr): '''Should be called to signalize a call directive. Args: span (tuple of int): Start and end line of the directive. - name (str): Name of the macro to call. + name (str): Name of the callable to call + argexpr (str or None): Argument expression containing additional + arguments for the call. ''' self._path.append(self._curnode) self._curnode = [] - self._open_blocks.append(('call', self._curfile, [span], name, [])) + self._open_blocks.append( + ('call', self._curfile, [span, span], name, argexpr, [], [])) - def handle_nextarg(self, span): + def handle_nextarg(self, span, name): '''Should be called to signalize a nextarg directive. Args: span (tuple of int): Start and end line of the directive. + name (str or None): Name of the argument following next or + None if it should be the next positional argument. ''' self._check_for_open_block(span, 'nextarg') block = self._open_blocks[-1] - directive, _, spans = block[0:3] - self._check_if_matches_last(directive, 'call', spans[-1], span, - 'endcall') - _, contents = block[3:5] - contents.append(self._curnode) + directive, fname, spans = block[0:3] + self._check_if_matches_last( + directive, 'call', spans[-1], span, 'nextarg') + args, argnames = block[5:7] + args.append(self._curnode) spans.append(span) + if name is not None: + argnames.append(name) + elif argnames: + msg = 'non-keyword argument following keyword argument' + raise FyppFatalError(msg, fname, span) self._curnode = [] - def handle_endcall(self, span): + def handle_endcall(self, span, name): '''Should be called to signalize an endcall directive. Args: span (tuple of int): Start and end line of the directive. + name (str): Name of the endcall statement. Could be None, if endcall + was specified without name. ''' self._check_for_open_block(span, 'endcall') block = self._open_blocks.pop(-1) - directive, _, spans = block[0:3] - self._check_if_matches_last(directive, 'call', spans[-1], span, + directive, fname, spans = block[0:3] + self._check_if_matches_last(directive, 'call', spans[0], span, 'endcall') - _, contents = block[3:5] - contents.append(self._curnode) + callname, callargexpr, args, argnames = block[3:7] + if name is not None and name != callname: + msg = "wrong name in endcall directive "\ + "(expected '{0}', got '{1}')".format(callname, name) + raise FyppFatalError(msg, fname, span) + args.append(self._curnode) + # If nextarg or endcall immediately followed call, then first argument + # is empty and should be removed (to allow for calls without arguments + # and named first argument in calls) + if args and not args[0]: + if len(argnames) == len(args): + del argnames[0] + del args[0] + del spans[1] spans.append(span) + block = (directive, fname, spans, callname, callargexpr, args, argnames) self._curnode = self._path.pop(-1) self._curnode.append(block) - def handle_setvar(self, span, name, expr): - '''Should be called to signalize a setvar directive. + def handle_set(self, span, name, expr): + '''Should be called to signalize a set directive. Args: span (tuple of int): Start and end line of the directive. @@ -1043,7 +1154,27 @@ class Builder: expr (str): String representation of the expression to be assigned to the variable. ''' - self._curnode.append(('setvar', self._curfile, span, name, expr)) + self._curnode.append(('set', self._curfile, span, name, expr)) + + + def handle_global(self, span, name): + '''Should be called to signalize a global directive. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the variable(s) to make global. + ''' + self._curnode.append(('global', self._curfile, span, name)) + + + def handle_del(self, span, name): + '''Should be called to signalize a del directive. + + Args: + span (tuple of int): Start and end line of the directive. + name (str): Name of the variable(s) to delete. + ''' + self._curnode.append(('del', self._curfile, span, name)) def handle_eval(self, span, expr): @@ -1133,22 +1264,23 @@ class Builder: def _check_for_open_block(self, span, directive): if len(self._open_blocks) <= self._nr_prev_blocks[-1]: - msg = 'unexpected {} directive'.format(directive) + msg = 'unexpected {0} directive'.format(directive) raise FyppFatalError(msg, self._curfile, span) def _check_if_matches_last(self, lastdir, curdir, lastspan, curspan, directive): if curdir != lastdir: - msg = 'mismatching {} directive'.format(directive) + msg = "mismatching '{0}' directive (last block opened was '{1}')"\ + .format(directive, lastdir) raise FyppFatalError(msg, self._curfile, curspan) inline_last = lastspan[0] == lastspan[1] inline_cur = curspan[0] == curspan[1] if inline_last != inline_cur: if inline_cur: - msg = 'expecting line form of directive {}'.format(directive) + msg = 'expecting line form of directive {0}'.format(directive) else: - msg = 'expecting inline form of directive {}'.format(directive) + msg = 'expecting inline form of directive {0}'.format(directive) raise FyppFatalError(msg, self._curfile, curspan) elif inline_cur and curspan[0] != lastspan[0]: msg = 'inline directives of the same construct must be in the '\ @@ -1167,18 +1299,24 @@ class Renderer: defaults to False. contlinenums (bool, optional): Whether linenums for continuation should be generated, defaults to False. + linenumformat (str, optional): If set to "gfortran5", a workaround + for broken gfortran versions (version 5.1 and above) is applied when + emitting line numbering directives. linefolder (callable): Callable to use when folding a line. ''' def __init__(self, evaluator=None, linenums=False, contlinenums=False, - linefolder=None): + linenumformat=None, linefolder=None): # Evaluator to use for Python expressions self._evaluator = Evaluator() if evaluator is None else evaluator - self._evaluator.updateenv(_DATE_=time.strftime('%Y-%m-%d'), - _TIME_=time.strftime('%H:%M:%S')) - # Number of diversions, when > 0 we are within a macro call - self._diversions = 0 + # Whether rendered output is diverted and will be processed + # further before output (if True: no line numbering and post processing) + self._diverted = False + + # Whether file name and line numbers should be kept fixed and + # not updated (typically when rendering macro content) + self._fixedposition = False # Whether line numbering directives should be emitted self._linenums = linenums @@ -1186,6 +1324,9 @@ class Renderer: # Whether line numbering directives in continuation lines are needed. self._contlinenums = contlinenums + # Whether to use the fix for GFortran in the line numbering directives + self._linenum_gfortran5 = (linenumformat == 'gfortran5') + # Callable to be used for folding lines if linefolder is None: self._linefolder = lambda line: [line] @@ -1193,29 +1334,35 @@ class Renderer: self._linefolder = linefolder - def render(self, tree, env=None): + def render(self, tree, divert=False, fixposition=False): '''Renders a tree. Args: tree (fypp-tree): Tree to render. - env (dict, optional): Dictionary containing additional definitions - for the evaluator. The definitions are removed from the - the evaluator, once the rendering finished. - - Returns: - str: Rendered string. + divert (bool): Whether output will be diverted and sent for further + processing, so that no line numbering directives and + postprocessing are needed at this stage. (Default: False) + fixposition (bool): Whether file name and line position (variables + _FILE_ and _LINE_) should be kept at their current values or + should be updated continuously. (Default: False). + + Returns: str: Rendered string. ''' - output, eval_inds, eval_pos = self._render(tree, env) - if eval_inds: + diverted = self._diverted + self._diverted = divert + fixedposition = self._fixedposition + self._fixedposition = fixposition + output, eval_inds, eval_pos = self._render(tree) + if not self._diverted and eval_inds: self._postprocess_eval_lines(output, eval_inds, eval_pos) + self._diverted = diverted + self._fixedposition = fixedposition txt = ''.join(output) + return txt - def _render(self, tree, env=None): - newscope = env is not None - if newscope: - self._evaluator.pushenv(env) + def _render(self, tree): output = [] eval_inds = [] eval_pos = [] @@ -1236,16 +1383,18 @@ class Renderer: elif cmd == 'def': result = self._define_macro(*node[1:6]) output.append(result) - elif cmd == 'setvar': + elif cmd == 'set': result = self._define_variable(*node[1:5]) output.append(result) + elif cmd == 'del': + self._delete_variable(*node[1:4]) elif cmd == 'for': out, ieval, peval = self._get_iterated_content(*node[1:6]) eval_inds += _shiftinds(ieval, len(output)) eval_pos += peval output += out elif cmd == 'call': - out, ieval, peval = self._get_called_content(*node[1:5]) + out, ieval, peval = self._get_called_content(*node[1:7]) eval_inds += _shiftinds(ieval, len(output)) eval_pos += peval output += out @@ -1263,27 +1412,26 @@ class Renderer: elif cmd == 'assert': result = self._handle_assert(*node[1:4]) output.append(result) + elif cmd == 'global': + self._add_global(*node[1:4]) else: - msg = "internal error: unknown command '{}'".format(cmd) + msg = "internal error: unknown command '{0}'".format(cmd) raise FyppFatalError(msg) - if newscope: - self._evaluator.popenv() return output, eval_inds, eval_pos def _get_eval(self, fname, span, expr): - self._update_linenr(span[0]) try: - result = self._evaluator.evaluate(expr) + result = self._evaluate(expr, fname, span[0]) except Exception as exc: - msg = "exception occured when evaluating '{}'".format(expr) + msg = "exception occured when evaluating '{0}'".format(expr) raise FyppFatalError(msg, fname, span, exc) out = [] ieval = [] peval = [] if result is not None: out.append(str(result)) - if not self._diversions: + if not self._diverted: ieval.append(0) peval.append((span, fname)) if span[0] != span[1]: @@ -1297,22 +1445,21 @@ class Renderer: peval = [] multiline = (spans[0][0] != spans[-1][1]) for condition, content, span in zip(conditions, contents, spans): - self._update_linenr(span[1]) try: - cond = bool(self._evaluator.evaluate(condition)) + cond = bool(self._evaluate(condition, fname, span[0])) except Exception as exc: - msg = "exception occured when evaluating '{}'"\ + msg = "exception occured when evaluating '{0}'"\ .format(condition) raise FyppFatalError(msg, fname, span, exc) if cond: - if self._linenums and not self._diversions and multiline: + if self._linenums and not self._diverted and multiline: out.append(linenumdir(span[1], fname)) outcont, ievalcont, pevalcont = self._render(content) ieval += _shiftinds(ievalcont, len(out)) peval += pevalcont out += outcont break - if self._linenums and not self._diversions and multiline: + if self._linenums and not self._diverted and multiline: out.append(linenumdir(spans[-1][1], fname)) return out, ieval, peval @@ -1321,94 +1468,203 @@ class Renderer: out = [] ieval = [] peval = [] - self._update_linenr(spans[0][1]) try: - iterobj = iter(self._evaluator.evaluate(loopiter)) + iterobj = iter(self._evaluate(loopiter, fname, spans[0][0])) except Exception as exc: - msg = "exception occured when evaluating '{}'"\ + msg = "exception occured when evaluating '{0}'"\ .format(loopiter) raise FyppFatalError(msg, fname, spans[0], exc) multiline = (spans[0][0] != spans[-1][1]) for var in iterobj: if len(loopvars) == 1: - loopscope = {loopvars[0]: var} + self._define(loopvars[0], var) else: - loopscope = {varname: value - for varname, value in zip(loopvars, var)} - if self._linenums and not self._diversions and multiline: + for varname, value in zip(loopvars, var): + self._define(varname, value) + if self._linenums and not self._diverted and multiline: out.append(linenumdir(spans[0][1], fname)) - outcont, ievalcont, pevalcont = self._render(content, loopscope) + outcont, ievalcont, pevalcont = self._render(content) ieval += _shiftinds(ievalcont, len(out)) peval += pevalcont out += outcont - if self._linenums and not self._diversions and multiline: + if self._linenums and not self._diverted and multiline: out.append(linenumdir(spans[1][1], fname)) return out, ieval, peval - def _get_called_content(self, fname, spans, name, contents): + def _get_called_content(self, fname, spans, name, argexpr, contents, + argnames): + posargs, kwargs = self._get_call_arguments(fname, spans, argexpr, + contents, argnames) + try: + callobj = self._evaluate(name, fname, spans[0][0]) + result = callobj(*posargs, **kwargs) + except Exception as exc: + msg = "exception occured when calling '{0}'".format(name) + raise FyppFatalError(msg, fname, spans[0], exc) + self._update_predef_globals(fname, spans[0][0]) + span = (spans[0][0], spans[-1][1]) + out = [] + ieval = [] + peval = [] + if result is not None: + out = [str(result)] + if not self._diverted: + ieval = [0] + peval = [(span, fname)] + if span[0] != span[1]: + out.append('\n') + return out, ieval, peval + + + def _get_call_arguments(self, fname, spans, argexpr, contents, argnames): + if argexpr is None: + posargs = [] + kwargs = {} + else: + # Parse and evaluate arguments passed in call header + self._evaluator.openscope() + try: + posargs, kwargs = self._evaluate( + '__getargvalues(' + argexpr + ')', fname, spans[0][0]) + except Exception as exc: + msg = "unable to parse argument expression '{0}'"\ + .format(argexpr) + raise FyppFatalError(msg, fname, spans[0], exc) + self._evaluator.closescope() + + # Render arguments passed in call body args = [] - self._divert() for content in contents: - out = self.render(content, {}) - if len(out) and out[-1] == '\n': - out = out[:-1] - out_escaped = out.replace('\\', '\\\\') - out_escaped = out_escaped.replace('"', r'\"') - args.append('"""' + out_escaped + '"""') - self._undivert() - expr = "{}({})".format(name, ','.join(args)) - out, ieval, peval = self._get_eval( - fname, (spans[0][0], spans[-1][1]), expr) - return out, ieval, peval + self._evaluator.openscope() + rendered = self.render(content, divert=True) + self._evaluator.closescope() + if rendered.endswith('\n'): + rendered = rendered[:-1] + args.append(rendered) + + # Separate arguments in call body into positional and keyword ones: + if argnames: + posargs += args[:len(args) - len(argnames)] + offset = len(args) - len(argnames) + for iargname, argname in enumerate(argnames): + ind = offset + iargname + if argname in kwargs: + msg = "keyword argument '{0}' already defined"\ + .format(argname) + raise FyppFatalError(msg, fname, spans[ind + 1]) + kwargs[argname] = args[ind] + else: + posargs += args + + return posargs, kwargs def _get_included_content(self, fname, spans, includefname, content): + includefile = spans[0] is not None out = [] - self._evaluator.updateenv(_FILE_=includefname) - if self._linenums and not self._diversions: - out += linenumdir(0, includefname, 1) + if self._linenums and not self._diverted: + if includefile or self._linenum_gfortran5: + out += linenumdir(0, includefname, _LINENUM_NEW_FILE) + else: + out += linenumdir(0, includefname) outcont, ieval, peval = self._render(content) ieval = _shiftinds(ieval, len(out)) out += outcont - self._evaluator.updateenv(_FILE_=fname) - if self._linenums and not self._diversions and spans[0] is not None: - out += linenumdir(spans[0][1], fname, 2) + if self._linenums and not self._diverted and includefile: + out += linenumdir(spans[0][1], fname, _LINENUM_RETURN_TO_FILE) return out, ieval, peval - def _define_macro(self, fname, spans, name, args, content): + def _define_macro(self, fname, spans, name, argexpr, content): + if argexpr is None: + args = [] + defaults = {} + varargs = None + else: + # Try to create a lambda function with the argument expression + self._evaluator.openscope() + lambdaexpr = 'lambda ' + argexpr + ': None' + try: + func = self._evaluate(lambdaexpr, fname, spans[0][0]) + except Exception as exc: + msg = "exception occured when evaluating argument expression "\ + "'{0}'".format(argexpr) + raise FyppFatalError(msg, fname, spans[0], exc) + self._evaluator.closescope() + try: + args, defaults, varargs = _get_callable_argspec(func) + except Exception as exc: + msg = "invalid argument expression '{0}'".format(argexpr) + raise FyppFatalError(msg, fname, spans[0], exc) + named_args = args if varargs is None else args + [varargs] + for arg in named_args: + if arg in _RESERVED_NAMES or arg.startswith(_RESERVED_PREFIX): + msg = "invalid argument name '{0}'".format(arg) + raise FyppFatalError(msg, fname, spans[0]) result = '' try: - macro = _Macro(name, fname, spans, args, content, self.render, - self._divert, self._undivert) - self._evaluator.define(name, macro) + macro = _Macro( + name, fname, spans, args, defaults, varargs, content, self, + self._evaluator, self._evaluator.localscope) + self._define(name, macro) except Exception as exc: - msg = "exception occured when defining macro '{}'"\ + msg = "exception occured when defining macro '{0}'"\ .format(name) raise FyppFatalError(msg, fname, spans[0], exc) - if self._linenums and not self._diversions: + if self._linenums and not self._diverted: result = linenumdir(spans[1][1], fname) return result def _define_variable(self, fname, span, name, valstr): result = '' - self._update_linenr(span[0]) try: - self._evaluator.define(name, self._evaluator.evaluate(valstr)) + if valstr is None: + expr = None + else: + expr = self._evaluate(valstr, fname, span[0]) + self._define(name, expr) except Exception as exc: - msg = "exception occured when setting variable(s) {} to {}"\ + msg = "exception occured when setting variable(s) '{0}' to '{1}'"\ .format(name, valstr) raise FyppFatalError(msg, fname, span, exc) multiline = (span[0] != span[1]) - if self._linenums and not self._diversions and multiline: + if self._linenums and not self._diverted and multiline: + result = linenumdir(span[1], fname) + return result + + + def _delete_variable(self, fname, span, name): + result = '' + try: + self._evaluator.undefine(name) + except Exception as exc: + msg = "exception occured when deleting variable(s) '{0}'"\ + .format(name) + raise FyppFatalError(msg, fname, span, exc) + multiline = (span[0] != span[1]) + if self._linenums and not self._diverted and multiline: + result = linenumdir(span[1], fname) + return result + + + def _add_global(self, fname, span, name): + result = '' + try: + self._evaluator.addglobal(name) + except Exception as exc: + msg = "exception occured when making variable(s) '{0}' global"\ + .format(name) + raise FyppFatalError(msg, fname, span, exc) + multiline = (span[0] != span[1]) + if self._linenums and not self._diverted and multiline: result = linenumdir(span[1], fname) return result def _get_comment(self, fname, span): - if self._linenums and not self._diversions: + if self._linenums and not self._diverted: return linenumdir(span[1], fname) else: return '' @@ -1416,18 +1672,17 @@ class Renderer: def _get_muted_content(self, fname, spans, content): self._render(content) - if self._linenums and not self._diversions: + if self._linenums and not self._diverted: return linenumdir(spans[-1][1], fname) else: return '' def _handle_stop(self, fname, span, msgstr): - self._update_linenr(span[0]) try: - msg = str(self._evaluator.evaluate(msgstr)) + msg = str(self._evaluate(msgstr, fname, span[0])) except Exception as exc: - msg = "exception occured when evaluating stop message '{}'"\ + msg = "exception occured when evaluating stop message '{0}'"\ .format(msgstr) raise FyppFatalError(msg, fname, span, exc) raise FyppStopRequest(msg, fname, span) @@ -1435,35 +1690,37 @@ class Renderer: def _handle_assert(self, fname, span, expr): result = '' - self._update_linenr(span[0]) try: - cond = bool(self._evaluator.evaluate(expr)) + cond = bool(self._evaluate(expr, fname, span[0])) except Exception as exc: - msg = "exception occured when evaluating assert condition '{}'"\ + msg = "exception occured when evaluating assert condition '{0}'"\ .format(expr) raise FyppFatalError(msg, fname, span, exc) if not cond: - msg = "Assertion failed ('{}')".format(expr) + msg = "Assertion failed ('{0}')".format(expr) raise FyppStopRequest(msg, fname, span) - if self._linenums and not self._diversions: + if self._linenums and not self._diverted: result = linenumdir(span[1], fname) return result - def _divert(self): - self._diversions += 1 + def _evaluate(self, expr, fname, linenr): + self._update_predef_globals(fname, linenr) + result = self._evaluator.evaluate(expr) + self._update_predef_globals(fname, linenr) + return result - def _undivert(self): - self._diversions -= 1 - if self._diversions < 0: - msg = "Internal error: undivert without matching divert" - raise FyppFatalError(msg) + def _update_predef_globals(self, fname, linenr): + self._evaluator.updatelocals( + _DATE_=time.strftime('%Y-%m-%d'), _TIME_=time.strftime('%H:%M:%S'), + _THIS_FILE_=fname, _THIS_LINE_=linenr + 1) + if not self._fixedposition: + self._evaluator.updateglobals(_FILE_=fname, _LINE_=linenr + 1) - def _update_linenr(self, linenr): - if not self._diversions: - self._evaluator.updateenv(_LINE_=linenr + 1) + def _define(self, var, value): + self._evaluator.define(var, value) def _postprocess_eval_lines(self, output, eval_inds, eval_pos): @@ -1576,24 +1833,18 @@ class Evaluator: '''Provides an isolated environment for evaluating Python expressions. - It can restrict the builtins which can be used within this environment - to a (hopefully safe) subset. Additionally it defines the functions - which are provided by the preprocessor for the eval directives. - - Note, that the restricted environment does not allow importing Python - modules. If you need a restricted environment with modules loaded, - launch a non-restricted one, load the modules, export its environment - and launch a restricted one using that environment. + It restricts the builtins which can be used within this environment to a + (hopefully safe) subset. Additionally it defines the functions which are + provided by the preprocessor for the eval directives. Args: env (dict, optional): Initial definitions for the environment, defaults to None. - restricted (bool, optional): Whether the restricted builtins should - be used. Otherwise all Python builtins are accessible. Defaults to - `True` (restricted environment. ''' - RESTRICTED_BUILTINS = { + # Restricted builtins working in all supported Python verions. Version + # specific ones are added dynamically in _get_restricted_builtins(). + _RESTRICTED_BUILTINS = { 'abs': builtins.abs, 'all': builtins.all, 'any': builtins.any, @@ -1601,7 +1852,6 @@ class Evaluator: 'bool': builtins.bool, 'bytearray': builtins.bytearray, 'bytes': builtins.bytes, - 'callable': builtins.callable, 'chr': builtins.chr, 'classmethod': builtins.classmethod, 'complex': builtins.complex, @@ -1629,7 +1879,6 @@ class Evaluator: 'locals': builtins.locals, 'map': builtins.map, 'max': builtins.max, - 'memoryview': builtins.memoryview, 'min': builtins.min, 'next': builtins.next, 'object': builtins.object, @@ -1653,30 +1902,27 @@ class Evaluator: 'type': builtins.type, 'vars': builtins.vars, 'zip': builtins.zip, - # For Python2 True/False must be explicitely added - 'True': True, - 'False': False, } - def __init__(self, env=None, restricted=True): - # Definitions (environment) to use when evaluating expressions - self._env = env.copy() if env is not None else {} - # Stack for environments to implement nested scopes - self._envstack = [] + def __init__(self, env=None): - if restricted: - builtindict = {} - builtindict.update(self.RESTRICTED_BUILTINS) - builtindict['__import__'] = self._func_import - else: - builtindict = vars(builtins) - builtindict['defined'] = self._func_defined - builtindict['setvar'] = self._func_setvar - builtindict['getvar'] = self._func_getvar + # Global scope + self._globals = env if env is not None else {} - # Permitted builtins when evaluating expressions - self._builtins = {'__builtins__': builtindict} + # Local scope(s) + self._locals = None + self._locals_stack = [] + + # Variables which are references to entries in global scope + self._globalrefs = None + self._globalrefs_stack = [] + + # Current scope (globals + locals in all embedding and in current scope) + self._scope = self._globals + + # Turn on restricted mode + self._restrict_builtins() def evaluate(self, expr): @@ -1688,17 +1934,31 @@ class Evaluator: Return: Python object: Result of the expression evaluation. ''' - result = eval(expr, self._builtins, self._env) + result = eval(expr, self._scope) return result - def execute(self, code): - '''Run Python code using the `exec()` builtin. + def import_module(self, module): + '''Import a module into the evaluator. + + Note: Import only trustworthy modules! Module imports are global, + therefore, importing a malicious module which manipulates other global + modules could affect code behaviour outside of the Evaluator as well. Args: - code (str): Python code to run. + module (str): Python module to import. + + Raises: + FyppFatalError: If module could not be imported. + ''' - exec(code, self._builtins, self._env) + rootmod = module.split('.', 1)[0] + try: + imported = __import__(module, self._scope) + self.define(rootmod, imported) + except Exception as exc: + msg = "failed to import module '{0}'".format(module) + raise FyppFatalError(msg, cause=exc) def define(self, name, value): @@ -1709,140 +1969,339 @@ class Evaluator: value (Python object): Value of the entity. Raises: - FyppFatalError: If name starts with the reserved prefix or if it is a - reserved name. + FyppFatalError: If name starts with the reserved prefix or if it is + a reserved name. ''' - lpar = name.startswith('(') - rpar = name.endswith(')') - if lpar != rpar: - msg = "unbalanced paranthesis around variable name(s) in '{}'"\ - .format(name) - raise FyppFatalError(msg, None, None) - if lpar: - name = name[1:-1] - varnames = [s.strip() for s in name.split(',')] + varnames = self._get_variable_names(name) if len(varnames) == 1: value = (value,) - for ind, varname in enumerate(varnames): - if varname.startswith(_RESERVED_PREFIX): - msg = "Name '{}' starts with reserved prefix '{}'"\ - .format(varname, _RESERVED_PREFIX) - raise FyppFatalError(msg, None, None) - if varname in _RESERVED_NAMES: - msg = "Name '{}' is reserved and can not be redefined"\ - .format(varname) - raise FyppFatalError(msg, None, None) - self._env[varname] = value[ind] + elif len(varnames) != len(value): + msg = 'value for tuple assignment has incompatible length' + raise FyppFatalError(msg) + for varname, varvalue in zip(varnames, value): + self._check_variable_name(varname) + if self._locals is None: + self._globals[varname] = varvalue + else: + if varname in self._globalrefs: + self._globals[varname] = varvalue + else: + self._locals[varname] = varvalue + self._scope[varname] = varvalue + + + def undefine(self, name): + '''Undefine a Python entity. + + Args: + name (str): Name of the entity to undefine. + + Raises: + FyppFatalError: If name starts with the reserved prefix or if it is + a reserved name. + ''' + varnames = self._get_variable_names(name) + for varname in varnames: + self._check_variable_name(varname) + deleted = False + if self._locals is None: + if varname in self._globals: + del self._globals[varname] + deleted = True + else: + if varname in self._locals: + del self._locals[varname] + del self._scope[varname] + deleted = True + elif varname in self._globalrefs and varname in self._globals: + del self._globals[varname] + del self._scope[varname] + deleted = True + if not deleted: + msg = "lookup for an erasable instance of '{0}' failed"\ + .format(varname) + raise FyppFatalError(msg) + + + def addglobal(self, name): + '''Define a given entity as global. + + Args: + name (str): Name of the entity to make global. + + Raises: + FyppFatalError: If entity name is invalid or if the current scope is + a local scope and entity is already defined in it. + ''' + varnames = self._get_variable_names(name) + for varname in varnames: + self._check_variable_name(varname) + if self._locals is not None: + if varname in self._locals: + msg = "variable '{0}' already defined in local scope"\ + .format(varname) + raise FyppFatalError(msg) + self._globalrefs.add(varname) + + + def updateglobals(self, **vardict): + '''Update variables in the global scope. + + This is a shortcut function to inject protected variables in the global + scope without extensive checks (as in define()). Vardict must not + contain any global entries which can be shadowed in local scopes + (e.g. should only contain variables with forbidden prefix). + + Args: + **vardict: variable defintions. + + ''' + self._scope.update(vardict) + if self._locals is not None: + self._globals.update(vardict) - def updateenv(self, **vardict): - '''Add variables to the environment. + def updatelocals(self, **vardict): + '''Update variables in the local scope. + + This is a shortcut function to inject variables in the local scope + without extensive checks (as in define()). Vardict must not contain any + entries which have been made global via addglobal() before. In order to + ensure this, updatelocals() should be called immediately after + openscope(), or with variable names, which are warrantedly not globals + (e.g variables starting with forbidden prefix) Args: **vardict: variable defintions. ''' - self._env.update(vardict) + self._scope.update(vardict) + if self._locals is not None: + self._locals.update(vardict) - def pushenv(self, vardict): - '''Push current environment to stack, and use its copy with additional - new defintions instead. + def openscope(self, customlocals=None): + '''Opens a new (embedded) scope. Args: - vardict (dict): New variables. + customlocals (dict): By default, the locals of the embedding scope + are visible in the new one. When this is not the desired + behaviour a dictionary of customized locals can be passed, + and those locals will become the only visible ones. ''' - self._envstack.append(self._env) - self._env = self._env.copy() - self._env.update(vardict) + self._locals_stack.append(self._locals) + self._globalrefs_stack.append(self._globalrefs) + if customlocals is not None: + self._locals = customlocals.copy() + elif self._locals is not None: + self._locals = self._locals.copy() + else: + self._locals = {} + self._globalrefs = set() + self._scope = self._globals.copy() + self._scope.update(self._locals) + + + def closescope(self): + '''Close scope and restore embedding scope.''' + self._locals = self._locals_stack.pop(-1) + self._globalrefs = self._globalrefs_stack.pop(-1) + if self._locals is not None: + self._scope = self._globals.copy() + self._scope.update(self._locals) + else: + self._scope = self._globals - def popenv(self): - '''Replace current environment with pop last one from stack.''' - self._env = self._envstack.pop(-1) + @property + def globalscope(self): + 'Dictionary of the global scope.' + return self._globals @property - def env(self): - '''Return current environment.''' - return self._env + def localscope(self): + 'Dictionary of the current local scope.' + return self._locals + + + def _restrict_builtins(self): + builtindict = self._get_restricted_builtins() + builtindict['__import__'] = self._func_import + builtindict['defined'] = self._func_defined + builtindict['setvar'] = self._func_setvar + builtindict['getvar'] = self._func_getvar + builtindict['delvar'] = self._func_delvar + builtindict['globalvar'] = self._func_globalvar + builtindict['__getargvalues'] = self._func_getargvalues + self._globals['__builtins__'] = builtindict + + + @classmethod + def _get_restricted_builtins(cls): + bidict = dict(cls._RESTRICTED_BUILTINS) + major = sys.version_info[0] + if major == 2: + bidict['True'] = True + bidict['False'] = False + return bidict + + + @staticmethod + def _get_variable_names(varexpr): + lpar = varexpr.startswith('(') + rpar = varexpr.endswith(')') + if lpar != rpar: + msg = "unbalanced paranthesis around variable varexpr(s) in '{0}'"\ + .format(varexpr) + raise FyppFatalError(msg, None, None) + if lpar: + varexpr = varexpr[1:-1] + varnames = [s.strip() for s in varexpr.split(',')] + return varnames + + + @staticmethod + def _check_variable_name(varname): + if varname.startswith(_RESERVED_PREFIX): + msg = "Name '{0}' starts with reserved prefix '{1}'"\ + .format(varname, _RESERVED_PREFIX) + raise FyppFatalError(msg, None, None) + if varname in _RESERVED_NAMES: + msg = "Name '{0}' is reserved and can not be redefined"\ + .format(varname) + raise FyppFatalError(msg, None, None) def _func_defined(self, var): - return var in self._env + defined = var in self._scope + return defined def _func_import(self, name, *_, **__): - module = self._env.get(name, None) + module = self._scope.get(name, None) if module is not None and isinstance(module, types.ModuleType): return module else: - msg = "Import of module '{}' via '__import__' not allowed" \ + msg = "Import of module '{0}' via '__import__' not allowed"\ .format(name) raise ImportError(msg) - def _func_setvar(self, name, value): - self.define(name, value) - return '' + def _func_setvar(self, *namesvalues): + if len(namesvalues) % 2: + msg = 'setvar function needs an even number of arguments' + raise FyppFatalError(msg) + for ind in range(0, len(namesvalues), 2): + self.define(namesvalues[ind], namesvalues[ind + 1]) - def _func_getvar(self, name, defvalue): - if name in self._env: - return self._env[name] + def _func_getvar(self, name, defvalue=None): + if name in self._scope: + return self._scope[name] else: return defvalue + def _func_delvar(self, *names): + for name in names: + self.undefine(name) + + + def _func_globalvar(self, *names): + for name in names: + self.addglobal(name) + + + @staticmethod + def _func_getargvalues(*args, **kwargs): + return list(args), kwargs + + + class _Macro: '''Represents a user defined macro. + This object should only be initiatied by a Renderer instance, as it + needs access to Renderers internal variables and methods. + Args: name (str): Name of the macro. fname (str): The file where the macro was defined. spans (str): Line spans of macro defintion. argnames (list of str): Macro dummy arguments. + varargs (str): Name of variable positional arguments or None. content (list): Content of the macro as tree. - renderfunc (function): Function to call when content should be rendered. - This is typically the corresponding render routine of the Builder. - divert (function): Function to call when macro rendering started, in - order to suppress its output. Typically the corresponding routine - of the Builder. - undivert (function): Function to call when macro rendering finished. - Typically the corresponding routine of the Builder. + renderer (Renderer): Renderer to use for evaluating macro content. + localscope (dict): Dictionary with local variables, which should be used + the local scope, when the macro is called. Default: None (empty + local scope). ''' - def __init__(self, name, fname, spans, argnames, content, renderfunc, - divert, undivert): + def __init__(self, name, fname, spans, argnames, defaults, varargs, content, + renderer, evaluator, localscope=None): self._name = name self._fname = fname self._spans = spans self._argnames = argnames + self._defaults = defaults + self._varargs = varargs self._content = content - self._renderfunc = renderfunc - self._divert = divert - self._undivert = undivert + self._renderer = renderer + self._evaluator = evaluator + self._localscope = localscope if localscope is not None else {} def __call__(self, *args, **keywords): - self._divert() - if len(args) != len(self._argnames): - msg = "Macro '{}' received incorrect nr. of positional arguments " \ - "(expected: {}, received: {})".format( - self._name, len(self._argnames), len(args)) - raise FyppFatalError(msg, self._fname, self._spans[0]) - argdict = {} - for argname, arg in zip(self._argnames, args): - argdict[argname] = arg - argdict.update(keywords) - output = self._renderfunc(self._content, argdict) - self._undivert() + argdict = self._process_arguments(args, keywords) + self._evaluator.openscope(customlocals=self._localscope) + self._evaluator.updatelocals(**argdict) + output = self._renderer.render(self._content, divert=True, + fixposition=True) + self._evaluator.closescope() if output.endswith('\n'): return output[:-1] else: return output + def _process_arguments(self, args, keywords): + argdict = {} + nargs = min(len(args), len(self._argnames)) + for iarg in range(nargs): + argdict[self._argnames[iarg]] = args[iarg] + if nargs < len(args): + if self._varargs is None: + msg = "macro '{0}' called with too many positional arguments "\ + "(expected: {1}, received: {2})"\ + .format(self._name, len(self._argnames), len(args)) + raise FyppFatalError(msg, self._fname, self._spans[0]) + else: + argdict[self._varargs] = tuple(args[nargs:]) + elif self._varargs is not None: + argdict[self._varargs] = () + for argname in self._argnames[:nargs]: + if argname in keywords: + msg = "got multiple values for argument '{0}'".format(argname) + raise FyppFatalError(msg, self._fname, self._spans[0]) + if self._varargs is not None and self._varargs in keywords: + msg = "got unexpected keyword argument '{0}'".format(self._varargs) + raise FyppFatalError(msg, self._fname, self._spans[0]) + argdict.update(keywords) + if nargs < len(self._argnames): + for argname in self._argnames[nargs:]: + if argname in argdict: + pass + elif argname in self._defaults: + argdict[argname] = self._defaults[argname] + else: + msg = "macro '{0}' called without mandatory positional "\ + "argument '{1}'".format(self._name, argname) + raise FyppFatalError(msg, self._fname, self._spans[0]) + return argdict + + + class Processor: '''Connects various objects with each other to create a processor. @@ -1879,7 +2338,9 @@ class Processor: self._parser.handle_text = self._builder.handle_text self._parser.handle_def = self._builder.handle_def self._parser.handle_enddef = self._builder.handle_enddef - self._parser.handle_setvar = self._builder.handle_setvar + self._parser.handle_set = self._builder.handle_set + self._parser.handle_del = self._builder.handle_del + self._parser.handle_global = self._builder.handle_global self._parser.handle_for = self._builder.handle_for self._parser.handle_endfor = self._builder.handle_endfor self._parser.handle_call = self._builder.handle_call @@ -1892,115 +2353,95 @@ class Processor: self._parser.handle_assert = self._builder.handle_assert - def process_file(self, fname, env=None): + def process_file(self, fname): '''Processeses a file. Args: fname (str): Name of the file to process. - env (dict): Additional definitons for the evaluator. Returns: str: Processed content. ''' self._parser.parsefile(fname) - return self._render(env) + return self._render() - def process_text(self, txt, env=None): + def process_text(self, txt): '''Processes a string. Args: txt (str): Text to process. - env (dict): Additional definitons for the evaluator. Returns: str: Processed content. ''' self._parser.parse(txt) - return self._render(env) + return self._render() - def _render(self, env): - env = {} if env is None else env - output = self._renderer.render(self._builder.tree, env) + def _render(self): + output = self._renderer.render(self._builder.tree) self._builder.reset() return ''.join(output) -def linenumdir(linenr, fname, flag=None): - '''Returns a line numbering directive. - - Args: - linenr (int): Line nr (starting with 0). - fname (str): File name. - ''' - if flag is None: - return '# {} "{}"\n'.format(linenr + 1, fname) - else: - return '# {} "{}" {}\n'.format(linenr + 1, fname, flag) - - class Fypp: '''Fypp preprocessor. You can invoke it like :: - tool = Fypp() + tool = fypp.Fypp() tool.process_file('file.in', 'file.out') to initialize Fypp with default options, process `file.in` and write the result to `file.out`. If the input should be read from a string, the ``process_text()`` method can be used:: - tool = Fypp() + tool = fypp.Fypp() output = tool.process_text('#:if DEBUG > 0\\nprint *, "DEBUG"\\n#:endif\\n') If you want to fine tune Fypps behaviour, pass a customized `FyppOptions`_ instance at initialization:: - options = FyppOptions() + options = fypp.FyppOptions() options.fixed_format = True - tool = Fypp(options) + tool = fypp.Fypp(options) - Alternatively, you can use the command line parser - ``argparse.ArgumentParser`` to set options for Fypp. The function - ``get_option_parser()`` returns you a default argument parser. You can then - use its ``parse_args()`` method to obtain settings by reading the command - line arguments:: + Alternatively, you can use the command line parser ``optparse.OptionParser`` + to set options for Fypp. The function ``get_option_parser()`` returns you a + default option parser. You can then use its ``parse_args()`` method to + obtain settings by reading the command line arguments:: - options = FyppOptions() - argparser = get_option_parser() - options = argparser.parse_args(namespace=options) + optparser = fypp.get_option_parser() + options, leftover = optparser.parse_args() tool = fypp.Fypp(options) - The command line arguments can also be passed directly as a list when + The command line options can also be passed directly as a list when calling ``parse_args()``:: - options = FyppOptions() args = ['-DDEBUG=0', 'input.fpp', 'output.f90'] - argparser = get_option_parser() - options = argparser.parse_args(args=args, namespace=options) + optparser = fypp.get_option_parser() + options, leftover = optparser.parse_args(args=args) tool = fypp.Fypp(options) Args: options (object): Object containing the settings for Fypp. You typically - would pass a customized `FyppOptions`_ instance or a ``Namespace`` - object as returned by an argument parser. If not present, the - default settings in `FyppOptions`_ are used. - + would pass a customized `FyppOptions`_ instance or an + ``optparse.Values`` object as returned by the option parser. If not + present, the default settings in `FyppOptions`_ are used. ''' def __init__(self, options=None): + syspath = self._get_syspath_without_scriptdir() + self._adjust_syspath(syspath) if options is None: options = FyppOptions() - inieval = Evaluator(restricted=False) + evaluator = Evaluator() if options.modules: - self._import_modules(options.modules, inieval) - if options.inifiles: - self._exec_inifiles(options.inifiles, inieval) - evaluator = Evaluator(env=inieval.env, restricted=True) + self._import_modules(options.modules, evaluator, syspath, + options.moduledirs) if options.defines: self._apply_definitions(options.defines, evaluator) parser = Parser(options.includes) @@ -2023,11 +2464,11 @@ class Fypp: self._create_parent_folder = options.create_parent_folder renderer = Renderer( evaluator, linenums=linenums, contlinenums=contlinenums, - linefolder=linefolder) + linenumformat=options.line_marker_format, linefolder=linefolder) self._preprocessor = Processor(parser, builder, renderer) - def process_file(self, infile, outfile=None, env=None): + def process_file(self, infile, outfile=None): '''Processes input file and writes result to output file. Args: @@ -2042,7 +2483,7 @@ class Fypp: str: Result of processed input, if no outfile was specified. ''' infile = STDIN if infile == '-' else infile - output = self._preprocessor.process_file(infile, env) + output = self._preprocessor.process_file(infile) if outfile is None: return output else: @@ -2055,7 +2496,7 @@ class Fypp: outfile.close() - def process_text(self, txt, env=None): + def process_text(self, txt): '''Processes a string. Args: @@ -2065,7 +2506,7 @@ class Fypp: Returns: str: Processed content. ''' - return self._preprocessor.process_text(txt, env) + return self._preprocessor.process_text(txt) @staticmethod @@ -2078,44 +2519,40 @@ class Fypp: try: value = evaluator.evaluate(words[1]) except Exception as exc: - msg = "exception at evaluating '{}' in definition for " \ - "'{}'".format(words[1], name) + msg = "exception at evaluating '{0}' in definition for " \ + "'{1}'".format(words[1], name) raise FyppFatalError(msg, cause=exc) evaluator.define(name, value) - @staticmethod - def _import_modules(modules, evaluator): + def _import_modules(self, modules, evaluator, syspath, moduledirs): + lookuppath = [] + if moduledirs is not None: + lookuppath += [os.path.abspath(moddir) for moddir in moduledirs] + lookuppath.append(os.path.abspath('.')) + lookuppath += syspath + self._adjust_syspath(lookuppath) for module in modules: - try: - evaluator.execute('import ' + module) - except Exception as exc: - msg = "exception occured during import of module '{}'"\ - .format(module) - raise FyppFatalError(msg, cause=exc) + evaluator.import_module(module) + self._adjust_syspath(syspath) @staticmethod - def _exec_inifiles(inifiles, evaluator): - for inifile in inifiles: - try: - inifp = open(inifile, 'r') - source = inifp.read() - inifp.close() - except IOError as exc: - msg = "IO error occured at reading file '{}'"\ - .format(inifile) - raise FyppFatalError(msg, cause=exc) - try: - code = compile(source, inifile, 'exec', dont_inherit=-1) - evaluator.execute(code) - except Exception as exc: - msg = "exception occured when executing ini-file '{}'"\ - .format(inifile) - raise FyppFatalError(msg, cause=exc) + def _get_syspath_without_scriptdir(): + '''Remove the folder of the fypp binary from the search path''' + syspath = list(sys.path) + scriptdir = os.path.abspath(os.path.dirname(sys.argv[0])) + if os.path.abspath(syspath[0]) == scriptdir: + del syspath[0] + return syspath + + + @staticmethod + def _adjust_syspath(syspath): + sys.path = syspath -class FyppOptions: +class FyppOptions(optparse.Values): '''Container for Fypp options with default values. @@ -2128,14 +2565,18 @@ class FyppOptions: in the output. Default: False line_numbering_mode (str): Line numbering mode 'full' or 'nocontlines'. Default: 'full'. + line_marker_format (str): Line marker format. Currently 'cpp' and + 'gfortran5' are supported. Later fixes the line marker handling bug + introduced in GFortran 5. Default: 'cpp'. line_length (int): Length of output lines. Default: 132. folding_mode (str): Folding mode 'smart', 'simple' or 'brute'. Default: 'smart'. no_folding (bool): Whether folding should be suppresed. Default: False. indentation (int): Indentation in continuation lines. Default: 4. modules (list of str): Modules to import at initialization. Default: []. - inifiles (list of str): Python files to execute at initialization. - Default: [] + moduledirs (list of str): Module lookup directories for importing user + specified modules. The specified paths are looked up *before* the + standard module locations in sys.path. fixed_format (bool): Whether input file is in fixed format. Default: False. create_parent_folder (bool): Whether the parent folder for the output @@ -2143,16 +2584,18 @@ class FyppOptions: ''' def __init__(self): + optparse.Values.__init__(self) self.defines = [] self.includes = [] self.line_numbering = False self.line_numbering_mode = 'full' + self.line_marker_format = 'cpp' self.line_length = 132 self.folding_mode = 'smart' self.no_folding = False self.indentation = 4 self.modules = [] - self.inifiles = [] + self.moduledirs = [] self.fixed_format = False self.create_parent_folder = False @@ -2182,8 +2625,8 @@ class FortranLineFolder: # east one character apart of indentation and two continuation signs minmaxlen = indent + len(prefix) + len(suffix) + 1 if maxlen < minmaxlen: - msg = 'Maximal line length less than {} when using an indentation' \ - 'of {}'.format(minmaxlen, indent) + msg = 'Maximal line length less than {0} when using an indentation'\ + ' of {1}'.format(minmaxlen, indent) raise FyppFatalError(msg) self._maxlen = maxlen self._indent = indent @@ -2282,95 +2725,111 @@ def get_option_parser(): '''Returns an option parser for the Fypp command line tool. Returns: - ArgumentParser: Parser which can create a namespace object with - Fypp settings based on command line arguments. + OptionParser: Parser which can create an optparse.Values object with + Fypp settings based on command line arguments. ''' + defs = FyppOptions() fypp_name = 'fypp' - fypp_desc = 'Preprocess source files with Fypp directives.' - parser = ArgumentParser(prog=fypp_name, description=fypp_desc) + fypp_desc = 'Preprocesses source code with Fypp directives. The input is '\ + 'read from INFILE (default: \'-\', stdin) and written to '\ + 'OUTFILE (default: \'-\', stdout).' + fypp_version = fypp_name + ' ' + VERSION + usage = '%prog [options] [INFILE] [OUTFILE]' + parser = optparse.OptionParser(prog=fypp_name, description=fypp_desc, + version=fypp_version, usage=usage) msg = 'define variable, value is interpreted as ' \ 'Python expression (e.g \'-DDEBUG=1\' sets DEBUG to the ' \ 'integer 1) or set to None if ommitted' - parser.add_argument('-D', '--define', action='append', dest='defines', - metavar='VAR[=VALUE]', help=msg) + parser.add_option('-D', '--define', action='append', dest='defines', + metavar='VAR[=VALUE]', default=defs.defines, help=msg) msg = 'add directory to the search paths for include files' - parser.add_argument('-I', '--include', action='append', dest='includes', - metavar='INCDIR', help=msg) - msg = 'put line numbering directives to the output' - parser.add_argument('-n', '--line-numbering', action='store_true', - default=False, help=msg) + parser.add_option('-I', '--include', action='append', dest='includes', + metavar='INCDIR', default=defs.includes, help=msg) + msg = 'import a python module at startup (import only trustworthy modules '\ + 'as they have access to an **unrestricted** Python environment!)' + parser.add_option('-m', '--module', action='append', dest='modules', + metavar='MOD', default=defs.modules, help=msg) + msg = 'directory to be searched for user imported modules before '\ + 'looking up standard locations in sys.path' + parser.add_option('-M', '--module-dir', action='append', + dest='moduledirs', metavar='MODDIR', + default=defs.moduledirs, help=msg) + msg = 'emit line numbering markers' + parser.add_option('-n', '--line-numbering', action='store_true', + dest='line_numbering', default=defs.line_numbering, + help=msg) msg = 'line numbering mode, \'full\' (default): line numbering '\ - 'directives generated whenever source and output lines are out '\ - 'of sync, \'nocontlines\': line numbering directives omitted '\ + 'markers generated whenever source and output lines are out '\ + 'of sync, \'nocontlines\': line numbering markers omitted '\ 'for continuation lines' - parser.add_argument('-N', '--line-numbering-mode', metavar='MODE', - choices=['full', 'nocontlines'], default='full', - help=msg) + parser.add_option('-N', '--line-numbering-mode', metavar='MODE', + choices=['full', 'nocontlines'], + default=defs.line_numbering_mode, + dest='line_numbering_mode', help=msg) + msg = 'line numbering marker format, \'cpp\' (default): GNU cpp format, '\ + '\'gfortran5\': modified markers to work around bug in GFortran 5 '\ + 'and above' + parser.add_option('--line-marker-format', metavar='FMT', + choices=['cpp', 'gfortran5'], dest='line_marker_format', + default=defs.line_marker_format, help=msg) msg = 'maximal line length (default: 132), lines modified by the '\ 'preprocessor are folded if becoming longer' - parser.add_argument('-l', '--line-length', type=int, default=132, - metavar='LEN', help=msg) + parser.add_option('-l', '--line-length', type=int, metavar='LEN', + dest='line_length', default=defs.line_length, help=msg) msg = 'line folding mode, \'smart\' (default): indentation context '\ 'and whitespace aware, \'simple\': indentation context aware, '\ '\'brute\': mechnical folding' - parser.add_argument('-f', '--folding-mode', metavar='MODE', - choices=['smart', 'simple', 'brute'], - default='smart', help=msg) + parser.add_option('-f', '--folding-mode', metavar='MODE', + choices=['smart', 'simple', 'brute'], dest='folding_mode', + default=defs.folding_mode, help=msg) msg = 'suppress line folding' - parser.add_argument('-F', '--no-folding', action='store_true', - dest='no_folding', default=False, help=msg) + parser.add_option('-F', '--no-folding', action='store_true', + dest='no_folding', default=defs.no_folding, help=msg) msg = 'indentation to use for continuation lines (default 4)' - parser.add_argument('--indentation', type=int, metavar='IND', - default=4, help=msg) - msg = 'import python module before starting the processing' - parser.add_argument('-m', '--module', action='append', dest='modules', - metavar='MOD', help=msg) - msg = 'execute python initialization script before starting processing' - parser.add_argument('-i', '--ini-file', action='append', - dest='inifiles', metavar='INI', help=msg) + parser.add_option('--indentation', type=int, metavar='IND', + dest='indentation', default=defs.indentation, help=msg) msg = 'produce fixed format output (any settings for options '\ '--line-length, --folding-method and --indentation are ignored)' - parser.add_argument('--fixed-format', action='store_true', - default=False, help=msg) + parser.add_option('--fixed-format', action='store_true', + dest='fixed_format', default=defs.fixed_format, help=msg) msg = 'create parent folders of the output file if they do not exist' - parser.add_argument('-p', '--create-parents', action='store_true', - default=False, dest='create_parent_folder', help=msg) - versionstr = '%(prog)s ' + VERSION - parser.add_argument('-v', '--version', action='version', - version=versionstr) + parser.add_option('-p', '--create-parents', action='store_true', + dest='create_parent_folder', + default=defs.create_parent_folder, help=msg) return parser -def _add_io_arguments(parser): - msg = "input file to be processed (default: '-', stdin)" - parser.add_argument('infile', nargs='?', default='-', help=msg) - msg = "output file where processed content will be written (default: " \ - "'-', stdout)" - parser.add_argument('outfile', nargs='?', default='-', help=msg) - - def run_fypp(): '''Run the Fypp command line tool.''' options = FyppOptions() - argparser = get_option_parser() - _add_io_arguments(argparser) - args = argparser.parse_args(namespace=options) + optparser = get_option_parser() + opts, leftover = optparser.parse_args(values=options) + infile = leftover[0] if len(leftover) > 0 else '-' + outfile = leftover[1] if len(leftover) > 1 else '-' try: - tool = Fypp(args) - tool.process_file(args.infile, args.outfile) + tool = Fypp(opts) + tool.process_file(infile, outfile) except FyppStopRequest as exc: - sys.stderr.write("STOP REQUEST in file '{}', line {}"\ - .format(exc.fname, exc.span[0] + 1)) - sys.stderr.write('\n') - sys.stderr.write(str(exc.msg)) - sys.stderr.write('\n') + sys.stderr.write(_formatted_exception(exc)) sys.exit(USER_ERROR_EXIT_CODE) except FyppFatalError as exc: - sys.stderr.write(str(exc)) - sys.stderr.write('\n') + sys.stderr.write(_formatted_exception(exc)) sys.exit(ERROR_EXIT_CODE) +def linenumdir(linenr, fname, flag=None): + '''Returns a line numbering directive. + + Args: + linenr (int): Line nr (starting with 0). + fname (str): File name. + ''' + if flag is None: + return '# {0} "{1}"\n'.format(linenr + 1, fname) + else: + return '# {0} "{1}" {2}\n'.format(linenr + 1, fname, flag) + + def _shiftinds(inds, shift): return [ind + shift for ind in inds] @@ -2379,7 +2838,7 @@ def _open_input_file(inpfile): try: inpfp = open(inpfile, 'r') except IOError as exc: - msg = "Failed to open file '{}' for read".format(inpfile) + msg = "Failed to open file '{0}' for read".format(inpfile) raise FyppFatalError(msg, cause=exc) return inpfp @@ -2392,16 +2851,128 @@ def _open_output_file(outfile, create_parents=False): os.makedirs(parentdir) except OSError as exc: if exc.errno != errno.EEXIST: - msg = "Folder '{}' can not be created"\ + msg = "Folder '{0}' can not be created"\ .format(parentdir) raise FyppFatalError(msg, cause=exc) try: outfp = open(outfile, 'w') except IOError as exc: - msg = "Failed to open file '{}' for write".format(outfile) + msg = "Failed to open file '{0}' for write".format(outfile) raise FyppFatalError(msg, cause=exc) return outfp +def _get_callable_argspec_py2(func): + argspec = inspect.getargspec(func) + if argspec.keywords is not None: + msg = "variable length keyword argument '{0}' found"\ + .format(argspec.keywords) + raise FyppFatalError(msg) + vararg = argspec.varargs + args = argspec.args + tuplearg = False + for elem in args: + tuplearg = tuplearg or isinstance(elem, list) + if tuplearg: + msg = 'tuple argument(s) found' + raise FyppFatalError(msg) + defaults = {} + if argspec.defaults is not None: + for ind, default in enumerate(argspec.defaults): + iarg = len(args) - len(argspec.defaults) + ind + defaults[args[iarg]] = default + return args, defaults, vararg + + +def _get_callable_argspec_py3(func): + sig = inspect.signature(func) + args = [] + defaults = {} + vararg = None + for param in sig.parameters.values(): + if param.kind == param.POSITIONAL_OR_KEYWORD: + args.append(param.name) + if param.default != param.empty: + defaults[param.name] = param.default + elif param.kind == param.VAR_POSITIONAL: + vararg = param.name + else: + msg = "argument '{0}' has invalid argument type".format(param.name) + raise FyppFatalError(msg) + return args, defaults, vararg + + +# Signature objects are available from Python 3.3 (and deprecated from 3.5) + +if sys.version_info[0] >= 3 and sys.version_info[1] >= 3: + _get_callable_argspec = _get_callable_argspec_py3 +else: + _get_callable_argspec = _get_callable_argspec_py2 + + +def _blank_match(match): + size = match.end() - match.start() + return " " * size + + +def _argsplit_fortran(argtxt): + txt = _INLINE_EVAL_REGION_REGEXP.sub(_blank_match, argtxt) + splitpos = [-1] + quote = None + closing_brace_stack = [] + closing_brace = None + for ind, char in enumerate(txt): + if quote: + if char == quote: + quote = None + continue + if char in _QUOTES_FORTRAN: + quote = char + continue + if char in _OPENING_BRACKETS_FORTRAN: + closing_brace_stack.append(closing_brace) + ind = _OPENING_BRACKETS_FORTRAN.index(char) + closing_brace = _CLOSING_BRACKETS_FORTRAN[ind] + continue + if char in _CLOSING_BRACKETS_FORTRAN: + if char == closing_brace: + closing_brace = closing_brace_stack.pop(-1) + continue + else: + msg = "unexpected closing delimiter '{0}' in expression '{1}' "\ + "at position {2}".format(char, argtxt, ind + 1) + raise FyppFatalError(msg) + if not closing_brace and char == _ARGUMENT_SPLIT_CHAR_FORTRAN: + splitpos.append(ind) + if quote or closing_brace: + msg = "open quotes or brackets in expression '{0}'".format(argtxt) + raise FyppFatalError(msg) + splitpos.append(len(txt)) + fragments = [argtxt[start + 1 : end] + for start, end in zip(splitpos, splitpos[1:])] + return fragments + + +def _formatted_exception(exc): + error_header_formstr = '{file}:{line}: ' + error_body_formstr = 'error: {errormsg} [{errorclass}]' + if not isinstance(exc, FyppError): + return error_body_formstr.format( + errormsg=str(exc), errorclass=exc.__class__.__name__) + out = [] + if exc.fname is not None: + if exc.span[1] > exc.span[0] + 1: + line = '{0}-{1}'.format(exc.span[0] + 1, exc.span[1]) + else: + line = '{0}'.format(exc.span[0] + 1) + out.append(error_header_formstr.format(file=exc.fname, line=line)) + out.append(error_body_formstr.format(errormsg=exc.msg, + errorclass=exc.__class__.__name__)) + if exc.cause is not None: + out.append('\n' + _formatted_exception(exc.cause)) + out.append('\n') + return ''.join(out) + + if __name__ == '__main__': run_fypp() diff --git a/src/Makefile.lib b/lib/make.build similarity index 84% rename from src/Makefile.lib rename to lib/make.build index faa1df8..16293c5 100644 --- a/src/Makefile.lib +++ b/lib/make.build @@ -7,6 +7,8 @@ # Needs the following variables: # FXX: Fortran 2003 compiler # FXXOPT: Options for the Fortran 2003 compiler +# LN: Linker +# LNOPT: Linker options # FYPP: FYPP pre-processor # FYPPOPT: Options for the FYPP pre-processor. You should use the -I option # with this directory, if you are invoking the makefile from somewhere @@ -18,16 +20,16 @@ .SUFFIXES: .SUFFIXES: .f90 .fpp .o -TARGETLIB = libmpifx.a +TARGET = libmpifx.a vpath % $(SRCDIR) .PHONY: all -all: $(TARGETLIB) +all: $(TARGET) -include $(SRCDIR)/Makefile.dep +include $(SRCDIR)/make.deps -$(TARGETLIB): $(module.o) +$(TARGET): $(module.o) ar r $@ $^ %.f90: %.fpp @@ -36,14 +38,10 @@ $(TARGETLIB): $(module.o) %.o: %.f90 $(FXX) $(FXXOPT) -c $< -.PHONY: clean realclean +.PHONY: clean clean: rm -f *.o -distclean: clean - rm -f *.mod - rm -f $(TARGETLIB) - ### Local Variables: ### mode:makefile ### End: diff --git a/src/Makefile.dep b/lib/make.deps similarity index 100% rename from src/Makefile.dep rename to lib/make.deps diff --git a/src/module.fpp b/lib/module.fpp similarity index 100% rename from src/module.fpp rename to lib/module.fpp diff --git a/src/mpifx.fypp b/lib/mpifx.fypp similarity index 100% rename from src/mpifx.fypp rename to lib/mpifx.fypp diff --git a/src/mpifx_abort.fpp b/lib/mpifx_abort.fpp similarity index 100% rename from src/mpifx_abort.fpp rename to lib/mpifx_abort.fpp diff --git a/src/mpifx_allgather.fpp b/lib/mpifx_allgather.fpp similarity index 100% rename from src/mpifx_allgather.fpp rename to lib/mpifx_allgather.fpp diff --git a/src/mpifx_allreduce.fpp b/lib/mpifx_allreduce.fpp similarity index 100% rename from src/mpifx_allreduce.fpp rename to lib/mpifx_allreduce.fpp diff --git a/src/mpifx_barrier.fpp b/lib/mpifx_barrier.fpp similarity index 100% rename from src/mpifx_barrier.fpp rename to lib/mpifx_barrier.fpp diff --git a/src/mpifx_bcast.fpp b/lib/mpifx_bcast.fpp similarity index 100% rename from src/mpifx_bcast.fpp rename to lib/mpifx_bcast.fpp diff --git a/src/mpifx_comm.fpp b/lib/mpifx_comm.fpp similarity index 100% rename from src/mpifx_comm.fpp rename to lib/mpifx_comm.fpp diff --git a/src/mpifx_common.fpp b/lib/mpifx_common.fpp similarity index 100% rename from src/mpifx_common.fpp rename to lib/mpifx_common.fpp diff --git a/src/mpifx_constants.fpp b/lib/mpifx_constants.fpp similarity index 100% rename from src/mpifx_constants.fpp rename to lib/mpifx_constants.fpp diff --git a/src/mpifx_finalize.fpp b/lib/mpifx_finalize.fpp similarity index 100% rename from src/mpifx_finalize.fpp rename to lib/mpifx_finalize.fpp diff --git a/src/mpifx_gather.fpp b/lib/mpifx_gather.fpp similarity index 100% rename from src/mpifx_gather.fpp rename to lib/mpifx_gather.fpp diff --git a/src/mpifx_get_processor_name.fpp b/lib/mpifx_get_processor_name.fpp similarity index 100% rename from src/mpifx_get_processor_name.fpp rename to lib/mpifx_get_processor_name.fpp diff --git a/src/mpifx_helper.fpp b/lib/mpifx_helper.fpp similarity index 100% rename from src/mpifx_helper.fpp rename to lib/mpifx_helper.fpp diff --git a/src/mpifx_init.fpp b/lib/mpifx_init.fpp similarity index 100% rename from src/mpifx_init.fpp rename to lib/mpifx_init.fpp diff --git a/src/mpifx_recv.fpp b/lib/mpifx_recv.fpp similarity index 100% rename from src/mpifx_recv.fpp rename to lib/mpifx_recv.fpp diff --git a/src/mpifx_reduce.fpp b/lib/mpifx_reduce.fpp similarity index 100% rename from src/mpifx_reduce.fpp rename to lib/mpifx_reduce.fpp diff --git a/src/mpifx_scatter.fpp b/lib/mpifx_scatter.fpp similarity index 100% rename from src/mpifx_scatter.fpp rename to lib/mpifx_scatter.fpp diff --git a/src/mpifx_send.fpp b/lib/mpifx_send.fpp similarity index 100% rename from src/mpifx_send.fpp rename to lib/mpifx_send.fpp diff --git a/make.arch.template b/make.arch.template index 698f27b..d424b41 100644 --- a/make.arch.template +++ b/make.arch.template @@ -5,8 +5,8 @@ # Fortran 2003 compiler FXX = mpif90 -# Fortran compiler otions -FXXOPT = -std=f2008 -Wall -pedantic +# Fortran compiler options +FXXOPT = -std=f2003 # Linker LN = $(FXX) @@ -14,9 +14,14 @@ LN = $(FXX) # Linker options LNOPT = -# FYPP interpreter -# (see https://github.com/aradi/fypp if not installed in your system yet) -FYPP = fypp +# FYPP interpreter (see https://github.com/aradi/fypp) +FYPP = $(ROOT)/external/fypp/fypp # FYPP interpreter options (e.g. -DDEBUG for debug mode) FYPPOPT = "" + +# Directory where the build should happen +BUILDDIR = $(ROOT)/_build + +# Where to copy files when installation is required +INSTALLDIR = $(ROOT)/_install diff --git a/makefile b/makefile new file mode 100644 index 0000000..5b06dbe --- /dev/null +++ b/makefile @@ -0,0 +1,32 @@ + +ROOT := $(PWD) + +.PHONY: all +all: lib + +include $(ROOT)/make.arch + +.PHONY: lib +lib: + mkdir -p $(BUILDDIR)/lib + $(MAKE) -C $(BUILDDIR)/lib ROOT=$(ROOT) SRCDIR=$(ROOT)/lib \ + FXX="$(FXX)" FXXOPT="$(FXXOPT)" LN="$(LN)" LNOPT="$(LNOPT)" \ + FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" -f $(ROOT)/lib/make.build + +.PHONY: install +install: lib + mkdir -p $(INSTALLDIR)/lib + cp $(BUILDDIR)/lib/*.a $(INSTALLDIR)/lib + mkdir -p $(INSTALLDIR)/include + cp $(BUILDDIR)/lib/*.mod $(INSTALLDIR)/include + +.PHONY: test +test: lib + mkdir -p $(BUILDDIR)/test + $(MAKE) -C $(BUILDDIR)/test ROOT=$(ROOT) BUILDROOT=$(BUILDDIR) \ + -f $(ROOT)/test/make.build + + +.PHONY: distclean +distclean: + rm -rf $(BUILDDIR) diff --git a/src/GNUmakefile b/src/GNUmakefile deleted file mode 100644 index 85cf3a9..0000000 --- a/src/GNUmakefile +++ /dev/null @@ -1,25 +0,0 @@ -############################################################################ -# -# Makefile to build the library. -# -# Edit "../make.arch" to adapt it to your system. -# -############################################################################ - -ROOT = .. - -SRCDIR = $(ROOT)/src - -include ../make.arch - -.PHONY: _FORCED_SUBMAKE_ -_FORCED_SUBMAKE_: - $(MAKE) \ - FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ - LN="$(LN)" LNOPT="$(LNOPT)" \ - FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" \ - SRCDIR="$(SRCDIR)" -f Makefile.lib - -.PHONY: clean distclean -clean distclean: - $(MAKE) SRCDIR="$(SRCDIR)" -f Makefile.lib $@ diff --git a/test/GNUmakefile b/test/GNUmakefile deleted file mode 100644 index 9050b9d..0000000 --- a/test/GNUmakefile +++ /dev/null @@ -1,70 +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. -# -############################################################################ - -include ../make.arch - -# Root directory -ROOT = .. - -# Directory where library source can be found -SRCDIR = $(ROOT)/src - -############################################################################ -# 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 .o - -TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ - test_allreduce test_gather test_allgather test_scatter - -all: $(TARGETS) - -# Create dependencies (make sure every targets .o file additionally depends on -# the external libary, as the library modfiles must been created first) -include Makefile.dep -$(TARGETS:=.o): _extlib_mpifx - -# Include linking rules for targets -define link-target -$(LN) $(LNOPT) -o $@ $(filter-out _%,$^) -L$(SRCDIR) -lmpifx -endef -include Makefile.targets - -%.o: %.f90 - $(FXX) $(FXXOPT) -I$(SRCDIR) -c $< - -.PHONY: clean realclean -clean: - $(MAKE) SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib clean - rm -f *.mod *.o _* - -distclean: clean - $(MAKE) SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib distclean - rm -f $(TARGETS) - - -############################################################################ -# Invoking the makefile of the library to build it in its directory -############################e################################################ -.PHONY: _FORCED_SUBMAKE_ - -_extlib_mpifx: _FORCED_SUBMAKE_ - touch -r $(SRCDIR)/libmpifx.a $@ - -_FORCED_SUBMAKE_: - $(MAKE) \ - FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ - LN="$(LN)" LNOPT="$(LNOPT)" \ - FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" \ - SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib diff --git a/test/Makefile.targets b/test/Makefile.targets deleted file mode 100644 index b09ddf5..0000000 --- a/test/Makefile.targets +++ /dev/null @@ -1,23 +0,0 @@ -test_bcast: $(test_bcast.o) - $(link-target) - -test_send_recv: $(test_send_recv.o) - $(link-target) - -test_comm_split: $(test_comm_split.o) - $(link-target) - -test_reduce: $(test_reduce.o) - $(link-target) - -test_allreduce: $(test_allreduce.o) - $(link-target) - -test_gather: $(test_gather.o) - $(link-target) - -test_allgather: $(test_allgather.o) - $(link-target) - -test_scatter: $(test_scatter.o) - $(link-target) diff --git a/test/make.build b/test/make.build new file mode 100644 index 0000000..b85ee87 --- /dev/null +++ b/test/make.build @@ -0,0 +1,73 @@ +############################################################################ +# +# Makefile for building some example programs +# +# Needs as variable: +# ROOT Source root directory +# BUILDROOT Build root directory +# +# The mpifx library must be already built in $(BUILDROOT)/lib +# +############################################################################ + + +############################################################################ +# Building some test/example programs. +############################################################################ + +.SUFFIXES: +.SUFFIXES: .f90 .o + +TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ + test_allreduce test_gather test_allgather test_scatter + +all: $(TARGETS) + +MPIFX_LIBDIR = $(BUILDROOT)/lib +MPIFX_INCDIR = $(BUILDROOT)/lib + +include $(ROOT)/make.arch + +# Directory where library source can be found +SRCDIR = $(ROOT)/test + +vpath % $(SRCDIR) + +%.o: %.f90 + $(FXX) $(FXXOPT) -I$(MPIFX_INCDIR) -c $< + +# Linking rules for targets +define link-target +$(LN) $(LNOPT) -o $@ $^ -L$(MPIFX_LIBDIR) -lmpifx +endef + +.PHONY: clean +clean: + rm -f *.mod *.o _* + + +include $(SRCDIR)/make.deps + +test_bcast: $(test_bcast.o) + $(link-target) + +test_send_recv: $(test_send_recv.o) + $(link-target) + +test_comm_split: $(test_comm_split.o) + $(link-target) + +test_reduce: $(test_reduce.o) + $(link-target) + +test_allreduce: $(test_allreduce.o) + $(link-target) + +test_gather: $(test_gather.o) + $(link-target) + +test_allgather: $(test_allgather.o) + $(link-target) + +test_scatter: $(test_scatter.o) + $(link-target) diff --git a/test/Makefile.dep b/test/make.deps similarity index 100% rename from test/Makefile.dep rename to test/make.deps From 16d7f7b41b693f63630083a8017221d36785c58e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 27 Dec 2017 13:40:40 +0100 Subject: [PATCH 23/72] Fix documentation --- LICENSE | 2 +- doc/doxygen/Doxyfile | 10 +++++----- doc/doxygen/fyppf90.sh | 4 ++++ doc/doxygen/m4f90.sh | 2 -- doc/sphinx/about.rst | 6 +++--- doc/sphinx/installing.rst | 33 +++++++++++++++------------------ doc/sphinx/license.rst | 2 +- doc/sphinx/routines.rst | 2 +- doc/sphinx/using.rst | 2 +- 9 files changed, 31 insertions(+), 32 deletions(-) create mode 100755 doc/doxygen/fyppf90.sh delete mode 100755 doc/doxygen/m4f90.sh diff --git a/LICENSE b/LICENSE index 1af00a5..ae5d9b4 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2018, Bálint Aradi +Copyright (C) 2018 Bálint Aradi All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/doc/doxygen/Doxyfile b/doc/doxygen/Doxyfile index 2c23cfb..cc11346 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 @@ -661,7 +661,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 +679,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 +763,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) diff --git a/doc/doxygen/fyppf90.sh b/doc/doxygen/fyppf90.sh new file mode 100755 index 0000000..3fe0ab2 --- /dev/null +++ b/doc/doxygen/fyppf90.sh @@ -0,0 +1,4 @@ +#!/bin/bash +srcdir=$(dirname $1) +fyppdir=$srcdir/../external/fypp +$fyppdir/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/about.rst b/doc/sphinx/about.rst index 7845b78..a151bf0 100644 --- a/doc/sphinx/about.rst +++ b/doc/sphinx/about.rst @@ -28,9 +28,9 @@ Using MPIFX the call above is as simple as:: call mpifx_bcast(comm, myarray) No redundant arguments, sensible defaults. Nevertheless the full functionality -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:: +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) diff --git a/doc/sphinx/installing.rst b/doc/sphinx/installing.rst index c134274..7cf8e90 100644 --- a/doc/sphinx/installing.rst +++ b/doc/sphinx/installing.rst @@ -5,7 +5,7 @@ In order to compile MPIFX, you need following prerequisites: * Fortran 2003 compiler, -* GNU M4 macro interpreter, +* Python (2.6, 2.7 or any 3.x release) * GNU Make. @@ -27,13 +27,10 @@ In order to create a precompiled library the source and customize the settings for the compilers and the linker according to your system. -#. Change to the `src/` folder. - #. Issue `make` to build the library. -#. Copy *all* module files (usually ending on `.mod` and the library - `libmpifx.a` to a place, where your Fortran compiler and your linker can - recognize them. +#. 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 @@ -54,29 +51,29 @@ 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 `src/` folder into a *separate* folder within your +#. 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 - (`Makefile.lib`) to build the module files and the library in the folder + (`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)`, `$(M4)` and `$(M4OPT)` contain the Fortran compiler, the - Fortran compiler options, the linker, the linker options, the M4 preprocessor - and its options, respectively, you would have something like:: + 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_SRCDIR) \ + $(MAKE) -C $(MPIFX_BUILDDIR) \ FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="$(M4OPT)" \ - -f Makefile.lib + 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. + 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 `GNUmakefile` in the `test/` folder of MPIFX, -which uses exactly the same technique to compile the library during the build -process for the tests. +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 index aa7600f..82258d1 100644 --- a/doc/sphinx/license.rst +++ b/doc/sphinx/license.rst @@ -3,7 +3,7 @@ License MPIFX is licensed under the simplified BSD license:: - Copyright (c) 2013, Bálint Aradi + Copyright (c) 2018, Bálint Aradi All rights reserved. diff --git a/doc/sphinx/routines.rst b/doc/sphinx/routines.rst index 19d9a21..a4eda1c 100644 --- a/doc/sphinx/routines.rst +++ b/doc/sphinx/routines.rst @@ -4,4 +4,4 @@ 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) or sphinx. +(see folder `doc/doxygen/` in the source tree). diff --git a/doc/sphinx/using.rst b/doc/sphinx/using.rst index 48b8a37..35c0a65 100644 --- a/doc/sphinx/using.rst +++ b/doc/sphinx/using.rst @@ -6,7 +6,7 @@ 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 can omit this step. + initialized it via the legacy `mpi_init()` call, you should omit this step. #. Initialize a communicator of `type(mpifx_comm)`. From 0776c99457fff1ec1176efe5030d515f5eb0b25e Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sat, 13 Jan 2018 16:36:48 +0000 Subject: [PATCH 24/72] Fixed project URL The reference to API and Online documentation are still ambiguous. --- src/libmpifx.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 index c5e0a4c..4632a41 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -1,14 +1,14 @@ !> \mainpage Modern Fortran wrappers around MPI routines !! -!! The open source library [MPIFX](https://www.bitbucket.org/aradi/mpifx) is +!! 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://aradi.bitbucket.org/mpifx/) +!! * [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://www.bitbucket.org/aradi/mpifx/) +!! * [Project home page](https://github.com/dftbplus/mpifx) !! for the source code, bug tracker and further information on the project. !! module libmpifx_module From 725340ca8459371926d0ad51ca2231c0bde000f3 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sat, 13 Jan 2018 19:34:15 +0000 Subject: [PATCH 25/72] Added link to documentation --- README.rst | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/README.rst b/README.rst index d60169e..a0b49d1 100644 --- a/README.rst +++ b/README.rst @@ -3,7 +3,9 @@ MPIFX - Modern Fortran Interface for MPI The open source library `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. +routines of the MPI library to make their use as simple as possible. The +documentation is included inside the repository, but is also available at +`mpifx.readthedocs.io `_. It currently contains only a few routines so far, but if those happen to be the ones you need, feel free to use this project (MPIFX is licensed under the From 75ed706bf10fc87285618f77a36b5aec48771d9d Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sun, 21 Jan 2018 21:33:20 +0000 Subject: [PATCH 26/72] Update README.rst --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index a0b49d1..7068878 100644 --- a/README.rst +++ b/README.rst @@ -5,7 +5,7 @@ The open source library `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. The documentation is included inside the repository, but is also available at -`mpifx.readthedocs.io `_. +`dftbplus.github.io `_. It currently contains only a few routines so far, but if those happen to be the ones you need, feel free to use this project (MPIFX is licensed under the From 43059c6fd7b3c25890e57df39c09c4b1ff02a36d Mon Sep 17 00:00:00 2001 From: Alessandro Pecchia Date: Thu, 1 Feb 2018 11:40:27 +0100 Subject: [PATCH 27/72] Add interface to mpi_gatherv --- src/Makefile.dep | 11 +++- src/libmpifx.F90 | 1 + src/mpifx_gatherv.F90 | 148 ++++++++++++++++++++++++++++++++++++++++++ src/mpifx_gatherv.m4 | 50 ++++++++++++++ 4 files changed, 208 insertions(+), 2 deletions(-) create mode 100644 src/mpifx_gatherv.F90 create mode 100644 src/mpifx_gatherv.m4 diff --git a/src/Makefile.dep b/src/Makefile.dep index e3e42e5..7cfe66c 100644 --- a/src/Makefile.dep +++ b/src/Makefile.dep @@ -33,6 +33,10 @@ mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) $(mpifx_gather.m4) _modobj_mpifx_gather_module = mpifx_gather.o +mpifx_gatherv.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 +mpifx_gatherv.o = mpifx_gatherv.o $($(_modobj_mpifx_common_module)) $(mpifx_gatherv.m4) +_modobj_mpifx_gatherv_module = mpifx_gatherv.o + mpifx_comm.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_comm.m4 mpifx_comm.o = mpifx_comm.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_comm.m4) _modobj_mpifx_comm_module = mpifx_comm.o @@ -61,6 +65,9 @@ _modobj_mpifx_helper_module = mpifx_helper.o mpifx_gather.m4: mpifx_common.m4 mpifx_gather.m4 = $(mpifx_common.m4) +mpifx_gatherv.m4: mpifx_common.m4 +mpifx_gatherv.m4 = $(mpifx_common.m4) + mpifx_finalize.m4: mpifx_common.m4 mpifx_finalize.m4 = $(mpifx_common.m4) @@ -96,8 +103,8 @@ mpifx_common.m4 = $(mpifx_helper.m4) mpifx_bcast.m4: mpifx_common.m4 mpifx_bcast.m4 = $(mpifx_common.m4) -libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) _modobj_libmpifx_module = libmpifx.o mpifx_allreduce.m4: mpifx_common.m4 diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 index 4632a41..ff58117 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -25,6 +25,7 @@ module libmpifx_module use mpifx_reduce_module use mpifx_allreduce_module use mpifx_gather_module + use mpifx_gatherv_module use mpifx_allgather_module use mpifx_scatter_module implicit none diff --git a/src/mpifx_gatherv.F90 b/src/mpifx_gatherv.F90 new file mode 100644 index 0000000..c119dc9 --- /dev/null +++ b/src/mpifx_gatherv.F90 @@ -0,0 +1,148 @@ +include(mpifx_gatherv.m4) + +!> 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 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%master) 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%master) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_gatherv + !! + interface mpifx_gatherv + module procedure & + & mpifx_gatherv_i1i1, mpifx_gatherv_i2i2, mpifx_gatherv_i3i3, & + & mpifx_gatherv_i4i4, mpifx_gatherv_i5i5, mpifx_gatherv_i6i6 + module procedure & + & mpifx_gatherv_s1s1, mpifx_gatherv_s2s2, mpifx_gatherv_s3s3, & + & mpifx_gatherv_s4s4, mpifx_gatherv_s5s5, mpifx_gatherv_s6s6 + module procedure & + & mpifx_gatherv_d1d1, mpifx_gatherv_d2d2, mpifx_gatherv_d3d3, & + & mpifx_gatherv_d4d4, mpifx_gatherv_d5d5, mpifx_gatherv_d6d6 + module procedure & + & mpifx_gatherv_c1c1, mpifx_gatherv_c2c2, mpifx_gatherv_c3c3, & + & mpifx_gatherv_c4c4, mpifx_gatherv_c5c5, mpifx_gatherv_c6c6 + module procedure & + & mpifx_gatherv_z1z1, mpifx_gatherv_z2z2, mpifx_gatherv_z3z3, & + & mpifx_gatherv_z4z4, mpifx_gatherv_z5z5, mpifx_gatherv_z6z6 + module procedure & + & mpifx_gatherv_l1l1, mpifx_gatherv_l2l2, mpifx_gatherv_l3l3, & + & mpifx_gatherv_l4l4, mpifx_gatherv_l5l5, mpifx_gatherv_l6l6 + end interface mpifx_gatherv + + +contains + + _subroutine_mpifx_gatherv_dr0(i1i1, integer, (:), 1, MPI_INTEGER) + _subroutine_mpifx_gatherv_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) + _subroutine_mpifx_gatherv_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + _subroutine_mpifx_gatherv_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + _subroutine_mpifx_gatherv_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_gatherv_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + + _subroutine_mpifx_gatherv_dr0(s1s1, real(sp), (:), 1, MPI_REAL) + _subroutine_mpifx_gatherv_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) + _subroutine_mpifx_gatherv_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + _subroutine_mpifx_gatherv_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + _subroutine_mpifx_gatherv_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_gatherv_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + + _subroutine_mpifx_gatherv_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gatherv_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gatherv_dr0(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gatherv_dr0(d4d4, real(dp), (:,:,:,:), 4, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gatherv_dr0(d5d5, real(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gatherv_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_PRECISION) + + + _subroutine_mpifx_gatherv_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + _subroutine_mpifx_gatherv_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + _subroutine_mpifx_gatherv_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + _subroutine_mpifx_gatherv_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_gatherv_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_gatherv_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + _subroutine_mpifx_gatherv_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gatherv_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gatherv_dr0(z3z3, complex(dp), (:,:,:), 3, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gatherv_dr0(z4z4, complex(dp), (:,:,:,:), 4, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gatherv_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gatherv_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_COMPLEX) + + + _subroutine_mpifx_gatherv_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_gatherv_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) + _subroutine_mpifx_gatherv_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + _subroutine_mpifx_gatherv_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + _subroutine_mpifx_gatherv_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_gatherv_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + +end module mpifx_gatherv_module diff --git a/src/mpifx_gatherv.m4 b/src/mpifx_gatherv.m4 new file mode 100644 index 0000000..1f4dca4 --- /dev/null +++ b/src/mpifx_gatherv.m4 @@ -0,0 +1,50 @@ +include(mpifx_common.m4) + +dnl ************************************************************************ +dnl *** mpifx_gatherv +dnl ************************************************************************ + +define(`_subroutine_mpifx_gatherv_dr0',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send/recv buffer rank (1, 2, etc.) +dnl $5: corresponding MPI type +dnl +!> Gathers results of variable length on one process (type $1). +!! +!! \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 root Root process for the result (default: mycomm%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$3 + integer, intent(in) :: recvcounts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: root0, error0, ii + integer, allocatable :: displs(:) + + _assert(.not. mycomm%master .or. size(recv) == sum(recvcounts)) + + _handle_inoptflag(root0, root, mycomm%masterrank) + + allocate(displs(mycomm%size)) + displs(1) = 0 + do ii = 2, mycomm%size + displs(ii) = displs(ii-1) + recvcounts(ii-1) + end do + call mpi_gatherv(send, size(send), $5, recv, recvcounts, displs, & + & $5, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error) + +end subroutine mpifx_gatherv_$1 +') + From ced69499ca9f678aafef6d31a3b468b2ea5b06ac Mon Sep 17 00:00:00 2001 From: Alessandro Pecchia Date: Fri, 2 Feb 2018 18:14:16 +0100 Subject: [PATCH 28/72] Add optional displs and test_gatherv --- src/mpifx_gatherv.F90 | 5 +-- src/mpifx_gatherv.m4 | 32 ++++++++++++----- test/GNUmakefile | 2 +- test/Makefile.dep | 3 ++ test/Makefile.targets | 3 ++ test/test_gatherv.f90 | 81 +++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 114 insertions(+), 12 deletions(-) create mode 100644 test/test_gatherv.f90 diff --git a/src/mpifx_gatherv.F90 b/src/mpifx_gatherv.F90 index c119dc9..751604a 100644 --- a/src/mpifx_gatherv.F90 +++ b/src/mpifx_gatherv.F90 @@ -18,8 +18,9 @@ module mpifx_gatherv_module !! 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 are - !! computed from recvcounts, assuming ordering with processor rank. + !! 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) !! diff --git a/src/mpifx_gatherv.m4 b/src/mpifx_gatherv.m4 index 1f4dca4..6721ef9 100644 --- a/src/mpifx_gatherv.m4 +++ b/src/mpifx_gatherv.m4 @@ -18,31 +18,45 @@ dnl !! \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%masterrank) !! \param error Error code on exit. !! -subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, root, error) +subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) type(mpifx_comm), intent(in) :: mycomm $2, intent(in) :: send$3 $2, intent(out) :: recv$3 integer, intent(in) :: recvcounts(:) + integer, intent(in), optional :: displs(:) integer, intent(in), optional :: root integer, intent(out), optional :: error integer :: root0, error0, ii - integer, allocatable :: displs(:) + integer, allocatable :: displs0(:) - _assert(.not. mycomm%master .or. size(recv) == sum(recvcounts)) _handle_inoptflag(root0, root, mycomm%masterrank) - allocate(displs(mycomm%size)) - displs(1) = 0 - do ii = 2, mycomm%size - displs(ii) = displs(ii-1) + recvcounts(ii-1) - end do - call mpi_gatherv(send, size(send), $5, recv, recvcounts, displs, & + if (mycomm%rank == root0) then + _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 + end if + + call mpi_gatherv(send, size(send), $5, recv, recvcounts, displs0, & & $5, root0, mycomm%id, error0) + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error) end subroutine mpifx_gatherv_$1 diff --git a/test/GNUmakefile b/test/GNUmakefile index bedfde6..f125633 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -23,7 +23,7 @@ SRCDIR = ../src .SUFFIXES: .f90 .F90 .o .m4 TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ - test_allreduce test_gather test_allgather test_scatter + test_allreduce test_gather test_allgather test_gatherv test_scatter all: $(TARGETS) diff --git a/test/Makefile.dep b/test/Makefile.dep index 7c7be27..f71e27f 100644 --- a/test/Makefile.dep +++ b/test/Makefile.dep @@ -6,6 +6,9 @@ test_allgather.o = test_allgather.o $($(_modobj_libmpifx_module)) test_gather.o: $$(_modobj_libmpifx_module) test_gather.o = test_gather.o $($(_modobj_libmpifx_module)) +test_gatherv.o: $$(_modobj_libmpifx_module) +test_gatherv.o = test_gatherv.o $($(_modobj_libmpifx_module)) + test_send_recv.o: $$(_modobj_libmpifx_module) test_send_recv.o = test_send_recv.o $($(_modobj_libmpifx_module)) diff --git a/test/Makefile.targets b/test/Makefile.targets index b09ddf5..250a035 100644 --- a/test/Makefile.targets +++ b/test/Makefile.targets @@ -19,5 +19,8 @@ test_gather: $(test_gather.o) test_allgather: $(test_allgather.o) $(link-target) +test_gatherv: $(test_gatherv.o) + $(link-target) + test_scatter: $(test_scatter.o) $(link-target) diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 new file mode 100644 index 0000000..5ec6336 --- /dev/null +++ b/test/test_gatherv.f90 @@ -0,0 +1,81 @@ +program test_gatherv + use libmpifx_module + implicit none + + type(mpifx_comm) :: mycomm + real, allocatable :: send1(:), send2(:,:) + real, allocatable :: recv1(:), recv2(:,:) + 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() + + ! I1 -> I1 + if (mycomm%master) write(*, *) 'Test gather rank=1 -> rank=1' + + allocate(send1(mycomm%rank+1)) + send1 = 1.0*(mycomm%rank+1) + if (mycomm%master) 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)) + allocate(recvcounts(0)) + end if + + + write(*, *) 'id:',mycomm%rank, "Send1 buffer:", send1(:) + + call mpifx_gatherv(mycomm, send1, recv1, recvcounts) + + call mpifx_barrier(mycomm) + + if (mycomm%master) then + write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 + deallocate(recvcounts) + end if + + call mpifx_barrier(mycomm) + + ! I2 -> I2 + if (mycomm%master) write(*, *) 'Test gather rank=2 -> rank=2' + + allocate(send2(10, mycomm%rank+1)) + send2 = 1.0 * mycomm%rank + if (mycomm%master) 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 + + + write(*, *) "id:",mycomm%rank, "Send2 buffer:", send2(:,:) + + call mpifx_gatherv(mycomm, send2, recv2, recvcounts) + + call mpifx_barrier(mycomm) + + if (mycomm%master) then + write(*, *) "id:",mycomm%rank, "Recv2 buffer:", recv2(:,:) + end if + + + call mpifx_finalize() + +end program test_gatherv From 3671b0481db14b02fbada7247d405b0ec8e740ed Mon Sep 17 00:00:00 2001 From: Alessandro Pecchia Date: Sat, 3 Feb 2018 13:14:07 +0100 Subject: [PATCH 29/72] Add I0->I1 subroutine in gatherv and a test --- src/Makefile.dep | 2 +- src/mpifx_gatherv.F90 | 18 +++++++++++++ src/mpifx_gatherv.m4 | 61 +++++++++++++++++++++++++++++++++++++++++-- test/test_gatherv.f90 | 32 ++++++++++++++++++++++- 4 files changed, 109 insertions(+), 4 deletions(-) diff --git a/src/Makefile.dep b/src/Makefile.dep index 7cfe66c..f6a745f 100644 --- a/src/Makefile.dep +++ b/src/Makefile.dep @@ -33,7 +33,7 @@ mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) $(mpifx_gather.m4) _modobj_mpifx_gather_module = mpifx_gather.o -mpifx_gatherv.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 +mpifx_gatherv.o: $$(_modobj_mpifx_common_module) mpifx_gatherv.m4 mpifx_gatherv.o = mpifx_gatherv.o $($(_modobj_mpifx_common_module)) $(mpifx_gatherv.m4) _modobj_mpifx_gatherv_module = mpifx_gatherv.o diff --git a/src/mpifx_gatherv.F90 b/src/mpifx_gatherv.F90 index 751604a..76e7834 100644 --- a/src/mpifx_gatherv.F90 +++ b/src/mpifx_gatherv.F90 @@ -71,21 +71,33 @@ module mpifx_gatherv_module module procedure & & mpifx_gatherv_i1i1, mpifx_gatherv_i2i2, mpifx_gatherv_i3i3, & & mpifx_gatherv_i4i4, mpifx_gatherv_i5i5, mpifx_gatherv_i6i6 + module procedure & + & mpifx_gatherv_i0i1 module procedure & & mpifx_gatherv_s1s1, mpifx_gatherv_s2s2, mpifx_gatherv_s3s3, & & mpifx_gatherv_s4s4, mpifx_gatherv_s5s5, mpifx_gatherv_s6s6 + module procedure & + & mpifx_gatherv_s0s1 module procedure & & mpifx_gatherv_d1d1, mpifx_gatherv_d2d2, mpifx_gatherv_d3d3, & & mpifx_gatherv_d4d4, mpifx_gatherv_d5d5, mpifx_gatherv_d6d6 + module procedure & + & mpifx_gatherv_d0d1 module procedure & & mpifx_gatherv_c1c1, mpifx_gatherv_c2c2, mpifx_gatherv_c3c3, & & mpifx_gatherv_c4c4, mpifx_gatherv_c5c5, mpifx_gatherv_c6c6 + module procedure & + & mpifx_gatherv_c0c1 module procedure & & mpifx_gatherv_z1z1, mpifx_gatherv_z2z2, mpifx_gatherv_z3z3, & & mpifx_gatherv_z4z4, mpifx_gatherv_z5z5, mpifx_gatherv_z6z6 + module procedure & + & mpifx_gatherv_z0z1 module procedure & & mpifx_gatherv_l1l1, mpifx_gatherv_l2l2, mpifx_gatherv_l3l3, & & mpifx_gatherv_l4l4, mpifx_gatherv_l5l5, mpifx_gatherv_l6l6 + module procedure & + & mpifx_gatherv_l0l1 end interface mpifx_gatherv @@ -145,5 +157,11 @@ module mpifx_gatherv_module _subroutine_mpifx_gatherv_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) _subroutine_mpifx_gatherv_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + _subroutine_mpifx_gatherv_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) + _subroutine_mpifx_gatherv_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) + _subroutine_mpifx_gatherv_dr1(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_gatherv_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) + _subroutine_mpifx_gatherv_dr1(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_gatherv_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) end module mpifx_gatherv_module diff --git a/src/mpifx_gatherv.m4 b/src/mpifx_gatherv.m4 index 6721ef9..c7aeba5 100644 --- a/src/mpifx_gatherv.m4 +++ b/src/mpifx_gatherv.m4 @@ -40,9 +40,7 @@ subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) if (mycomm%rank == root0) then _assert(size(recv) == sum(recvcounts)) - allocate(displs0(mycomm%size)) - if (present(displs)) then _assert(size(displs) == mycomm%size) displs0 = displs @@ -62,3 +60,62 @@ subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) end subroutine mpifx_gatherv_$1 ') + +define(`_subroutine_mpifx_gatherv_dr1',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send buffer size (1 or size(send)) +dnl $5: recv buffer rank specifier ((:), (:,:), etc.) +dnl $6: recv buffers rank (1, 2, etc.) +dnl $7: corresponding MPI type +dnl +!> Gathers results on one process (type $1). +!! +!! \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%masterrank) +!! \param error Error code on exit. +!! +subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$5 + 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(:) + + _handle_inoptflag(root0, root, mycomm%masterrank) + + if (mycomm%rank == root0) then + _assert(size(recv) == sum(recvcounts)) + _assert(size(recv, dim=$6) == 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, $4, $7, recv, recvcounts, displs0, & + & $7, root0, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error) + +end subroutine mpifx_gatherv_$1 +') + diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 index 5ec6336..fbd2d00 100644 --- a/test/test_gatherv.f90 +++ b/test/test_gatherv.f90 @@ -5,6 +5,7 @@ program test_gatherv type(mpifx_comm) :: mycomm real, allocatable :: send1(:), send2(:,:) real, allocatable :: recv1(:), recv2(:,:) + real :: send0 integer, allocatable :: recvcounts(:) integer, allocatable :: displs(:) integer :: ii, nrecv @@ -31,7 +32,6 @@ program test_gatherv allocate(recv1(0)) allocate(recvcounts(0)) end if - write(*, *) 'id:',mycomm%rank, "Send1 buffer:", send1(:) @@ -42,6 +42,7 @@ program test_gatherv if (mycomm%master) then write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 deallocate(recvcounts) + deallocate(recv1) end if call mpifx_barrier(mycomm) @@ -73,8 +74,37 @@ program test_gatherv if (mycomm%master) then write(*, *) "id:",mycomm%rank, "Recv2 buffer:", recv2(:,:) + deallocate(recvcounts) end if + call mpifx_barrier(mycomm) + + ! I0 -> I1 + if (mycomm%master) write(*, *) 'Test gather scalar -> rank=1' + + if (mycomm%master) 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 + send0 = mycomm%rank + 1 + end if + + write(*, *) 'id:',mycomm%rank, "Send scalar:", send0 + + call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) + + call mpifx_barrier(mycomm) + + if (mycomm%master) then + write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 + end if call mpifx_finalize() From 5db3c0ddb8b5ec4745a700f37dcf74ac2994efa3 Mon Sep 17 00:00:00 2001 From: Alessandro Pecchia Date: Sat, 3 Feb 2018 21:48:41 +0100 Subject: [PATCH 30/72] Clean test_gatherv --- test/test_gatherv.f90 | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 index fbd2d00..1edbd2f 100644 --- a/test/test_gatherv.f90 +++ b/test/test_gatherv.f90 @@ -15,7 +15,7 @@ program test_gatherv call mpifx_init() call mycomm%init() - ! I1 -> I1 + ! R1 -> R1 if (mycomm%master) write(*, *) 'Test gather rank=1 -> rank=1' allocate(send1(mycomm%rank+1)) @@ -37,7 +37,6 @@ program test_gatherv call mpifx_gatherv(mycomm, send1, recv1, recvcounts) - call mpifx_barrier(mycomm) if (mycomm%master) then write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 @@ -70,8 +69,6 @@ program test_gatherv call mpifx_gatherv(mycomm, send2, recv2, recvcounts) - call mpifx_barrier(mycomm) - if (mycomm%master) then write(*, *) "id:",mycomm%rank, "Recv2 buffer:", recv2(:,:) deallocate(recvcounts) @@ -79,9 +76,10 @@ program test_gatherv call mpifx_barrier(mycomm) - ! I0 -> I1 + ! R0 -> R1 if (mycomm%master) write(*, *) 'Test gather scalar -> rank=1' + send0 = mycomm%rank + 1 if (mycomm%master) then nrecv = mycomm%size allocate(recv1(nrecv)) @@ -92,15 +90,11 @@ program test_gatherv do ii = 1, mycomm%size displs(ii) = mycomm%size - ii end do - else - send0 = mycomm%rank + 1 end if write(*, *) 'id:',mycomm%rank, "Send scalar:", send0 call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) - - call mpifx_barrier(mycomm) if (mycomm%master) then write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 From 969c39002223348c29d9151f84491399e0064b68 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sat, 3 Feb 2018 21:46:14 +0000 Subject: [PATCH 31/72] Minor changes in the test example for gatherv --- test/test_gatherv.f90 | 77 +++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 44 deletions(-) diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 index 1edbd2f..f0a7baa 100644 --- a/test/test_gatherv.f90 +++ b/test/test_gatherv.f90 @@ -3,12 +3,13 @@ program test_gatherv implicit none type(mpifx_comm) :: mycomm - real, allocatable :: send1(:), send2(:,:) - real, allocatable :: recv1(:), recv2(:,:) - real :: send0 + 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 + integer :: ii, nrecv character(100) :: formstr character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" @@ -16,70 +17,61 @@ program test_gatherv call mycomm%init() ! R1 -> R1 - if (mycomm%master) write(*, *) 'Test gather rank=1 -> rank=1' - - allocate(send1(mycomm%rank+1)) - send1 = 1.0*(mycomm%rank+1) if (mycomm%master) then - ! recv1 size is 1+2+3+...+mycomm%size + write(*, *) 'Test gather rank=1 -> rank=1' + end if + allocate(send1(mycomm%rank+1)) + send1 = real(mycomm%rank+1, sp) + if (mycomm%master) 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 + do ii = 1, mycomm%size + recvcounts(ii) = ii + end do else allocate(recv1(0)) allocate(recvcounts(0)) end if - write(*, *) 'id:',mycomm%rank, "Send1 buffer:", send1(:) - call mpifx_gatherv(mycomm, send1, recv1, recvcounts) - - if (mycomm%master) then write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 deallocate(recvcounts) deallocate(recv1) end if - - call mpifx_barrier(mycomm) - - ! I2 -> I2 - if (mycomm%master) write(*, *) 'Test gather rank=2 -> rank=2' - allocate(send2(10, mycomm%rank+1)) - send2 = 1.0 * mycomm%rank + ! R2 -> R2 if (mycomm%master) then - ! recv1 size is 1+2+3+...+mycomm%size + write(*, *) 'Test gather rank=2 -> rank=2' + end if + allocate(send2(10, mycomm%rank+1)) + send2 = real(mycomm%rank + 1, sp) + if (mycomm%master) 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 + do ii = 1, mycomm%size + recvcounts(ii) = 10*ii + end do else allocate(recv2(0,0)) end if - - write(*, *) "id:",mycomm%rank, "Send2 buffer:", send2(:,:) - call mpifx_gatherv(mycomm, send2, recv2, recvcounts) - if (mycomm%master) then write(*, *) "id:",mycomm%rank, "Recv2 buffer:", recv2(:,:) deallocate(recvcounts) end if - call mpifx_barrier(mycomm) - - ! R0 -> R1 - if (mycomm%master) write(*, *) 'Test gather scalar -> rank=1' - - send0 = mycomm%rank + 1 + ! R0 -> R1 with specified receive pattern + if (mycomm%master) then + write(*, *) 'Test gather scalar -> rank=1' + end if + send0 = real(mycomm%rank + 1, sp) if (mycomm%master) then nrecv = mycomm%size allocate(recv1(nrecv)) @@ -87,19 +79,16 @@ program test_gatherv recvcounts = 1 allocate(displs(mycomm%size)) ! set a non trivial displs vector - do ii = 1, mycomm%size - displs(ii) = mycomm%size - ii + do ii = 1, mycomm%size + displs(ii) = mycomm%size - ii end do - end if - + end if write(*, *) 'id:',mycomm%rank, "Send scalar:", send0 - call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%master) then write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 end if call mpifx_finalize() - + end program test_gatherv From 08c4d317b9f2a58b6f1a81df129b4a7c9ade01d2 Mon Sep 17 00:00:00 2001 From: Alessandro Pecchia Date: Sun, 4 Feb 2018 18:41:54 +0100 Subject: [PATCH 32/72] Cosmetic output change in test_gatherv --- test/test_gatherv.f90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 index f0a7baa..cee179b 100644 --- a/test/test_gatherv.f90 +++ b/test/test_gatherv.f90 @@ -34,16 +34,16 @@ program test_gatherv allocate(recv1(0)) allocate(recvcounts(0)) end if - write(*, *) 'id:',mycomm%rank, "Send1 buffer:", send1(:) call mpifx_gatherv(mycomm, send1, recv1, recvcounts) if (mycomm%master) then - write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 + write(*, *) "Recv1 buffer:", recv1 deallocate(recvcounts) deallocate(recv1) end if ! R2 -> R2 if (mycomm%master) then + write(*, *) write(*, *) 'Test gather rank=2 -> rank=2' end if allocate(send2(10, mycomm%rank+1)) @@ -60,15 +60,15 @@ program test_gatherv else allocate(recv2(0,0)) end if - write(*, *) "id:",mycomm%rank, "Send2 buffer:", send2(:,:) call mpifx_gatherv(mycomm, send2, recv2, recvcounts) if (mycomm%master) then - write(*, *) "id:",mycomm%rank, "Recv2 buffer:", recv2(:,:) + write(*, *) "Recv2 buffer:", recv2(:,:) deallocate(recvcounts) end if ! R0 -> R1 with specified receive pattern if (mycomm%master) then + write(*, *) write(*, *) 'Test gather scalar -> rank=1' end if send0 = real(mycomm%rank + 1, sp) @@ -83,10 +83,9 @@ program test_gatherv displs(ii) = mycomm%size - ii end do end if - write(*, *) 'id:',mycomm%rank, "Send scalar:", send0 call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) if (mycomm%master) then - write(*, *) 'id:',mycomm%rank, "Recv1 buffer:", recv1 + write(*, *) "Recv1 buffer:", recv1 end if call mpifx_finalize() From d869867f685b47ec78b5a411e1937cd6c24ad6d0 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sun, 4 Feb 2018 22:21:59 +0000 Subject: [PATCH 33/72] mpifx_allgatherv added --- src/Makefile.dep | 10 ++- src/libmpifx.F90 | 1 + src/mpifx_allgatherv.F90 | 163 +++++++++++++++++++++++++++++++++++++++ src/mpifx_allgatherv.m4 | 108 ++++++++++++++++++++++++++ test/GNUmakefile | 5 +- test/Makefile.dep | 3 + test/Makefile.targets | 5 +- test/test_allgatherv.f90 | 93 ++++++++++++++++++++++ 8 files changed, 383 insertions(+), 5 deletions(-) create mode 100644 src/mpifx_allgatherv.F90 create mode 100644 src/mpifx_allgatherv.m4 create mode 100644 test/test_allgatherv.f90 diff --git a/src/Makefile.dep b/src/Makefile.dep index f6a745f..f2b1ae4 100644 --- a/src/Makefile.dep +++ b/src/Makefile.dep @@ -79,6 +79,10 @@ mpifx_allgather.o: mpifx_allgather.m4 $$(_modobj_mpifx_common_module) mpifx_allgather.o = mpifx_allgather.o $(mpifx_allgather.m4) $($(_modobj_mpifx_common_module)) _modobj_mpifx_allgather_module = mpifx_allgather.o +mpifx_allgatherv.o: mpifx_allgatherv.m4 $$(_modobj_mpifx_common_module) +mpifx_allgatherv.o = mpifx_allgatherv.o $(mpifx_allgatherv.m4) $($(_modobj_mpifx_common_module)) +_modobj_mpifx_allgatherv_module = mpifx_allgatherv.o + mpifx_init.o: mpifx_init.m4 $$(_modobj_mpifx_common_module) mpifx_init.o = mpifx_init.o $(mpifx_init.m4) $($(_modobj_mpifx_common_module)) _modobj_mpifx_init_module = mpifx_init.o @@ -103,8 +107,8 @@ mpifx_common.m4 = $(mpifx_helper.m4) mpifx_bcast.m4: mpifx_common.m4 mpifx_bcast.m4 = $(mpifx_common.m4) -libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_allgatherv_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_allgatherv_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) _modobj_libmpifx_module = libmpifx.o mpifx_allreduce.m4: mpifx_common.m4 @@ -124,3 +128,5 @@ mpifx_comm.m4 = $(mpifx_helper.m4) mpifx_allgather.m4: mpifx_common.m4 mpifx_allgather.m4 = $(mpifx_common.m4) +mpifx_allgatherv.m4: mpifx_common.m4 +mpifx_allgatherv.m4 = $(mpifx_common.m4) diff --git a/src/libmpifx.F90 b/src/libmpifx.F90 index ff58117..03843c1 100644 --- a/src/libmpifx.F90 +++ b/src/libmpifx.F90 @@ -27,6 +27,7 @@ module libmpifx_module use mpifx_gather_module use mpifx_gatherv_module use mpifx_allgather_module + use mpifx_allgatherv_module use mpifx_scatter_module implicit none public diff --git a/src/mpifx_allgatherv.F90 b/src/mpifx_allgatherv.F90 new file mode 100644 index 0000000..ad3b087 --- /dev/null +++ b/src/mpifx_allgatherv.F90 @@ -0,0 +1,163 @@ +include(mpifx_allgatherv.m4) + +!> 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%master) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_allgatherv + !! + interface mpifx_allgatherv + module procedure & + & mpifx_allgatherv_i1i1, mpifx_allgatherv_i2i2, mpifx_allgatherv_i3i3, & + & mpifx_allgatherv_i4i4, mpifx_allgatherv_i5i5, mpifx_allgatherv_i6i6 + module procedure & + & mpifx_allgatherv_i0i1 + module procedure & + & mpifx_allgatherv_s1s1, mpifx_allgatherv_s2s2, mpifx_allgatherv_s3s3, & + & mpifx_allgatherv_s4s4, mpifx_allgatherv_s5s5, mpifx_allgatherv_s6s6 + module procedure & + & mpifx_allgatherv_s0s1 + module procedure & + & mpifx_allgatherv_d1d1, mpifx_allgatherv_d2d2, mpifx_allgatherv_d3d3, & + & mpifx_allgatherv_d4d4, mpifx_allgatherv_d5d5, mpifx_allgatherv_d6d6 + module procedure & + & mpifx_allgatherv_d0d1 + module procedure & + & mpifx_allgatherv_c1c1, mpifx_allgatherv_c2c2, mpifx_allgatherv_c3c3, & + & mpifx_allgatherv_c4c4, mpifx_allgatherv_c5c5, mpifx_allgatherv_c6c6 + module procedure & + & mpifx_allgatherv_c0c1 + module procedure & + & mpifx_allgatherv_z1z1, mpifx_allgatherv_z2z2, mpifx_allgatherv_z3z3, & + & mpifx_allgatherv_z4z4, mpifx_allgatherv_z5z5, mpifx_allgatherv_z6z6 + module procedure & + & mpifx_allgatherv_z0z1 + module procedure & + & mpifx_allgatherv_l1l1, mpifx_allgatherv_l2l2, mpifx_allgatherv_l3l3, & + & mpifx_allgatherv_l4l4, mpifx_allgatherv_l5l5, mpifx_allgatherv_l6l6 + module procedure & + & mpifx_allgatherv_l0l1 + end interface mpifx_allgatherv + + +contains + + _subroutine_mpifx_allgatherv_dr0(i1i1, integer, (:), 1, MPI_INTEGER) + _subroutine_mpifx_allgatherv_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) + _subroutine_mpifx_allgatherv_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + _subroutine_mpifx_allgatherv_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + _subroutine_mpifx_allgatherv_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + _subroutine_mpifx_allgatherv_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + + _subroutine_mpifx_allgatherv_dr0(s1s1, real(sp), (:), 1, MPI_REAL) + _subroutine_mpifx_allgatherv_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) + _subroutine_mpifx_allgatherv_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + _subroutine_mpifx_allgatherv_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + _subroutine_mpifx_allgatherv_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + _subroutine_mpifx_allgatherv_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + + _subroutine_mpifx_allgatherv_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgatherv_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgatherv_dr0(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgatherv_dr0(d4d4, real(dp), (:,:,:,:), 4, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgatherv_dr0(d5d5, real(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgatherv_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_PRECISION) + + + _subroutine_mpifx_allgatherv_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + _subroutine_mpifx_allgatherv_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(z3z3, complex(dp), (:,:,:), 3, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(z4z4, complex(dp), (:,:,:,:), 4, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, + MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgatherv_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, + MPI_DOUBLE_COMPLEX) + + + _subroutine_mpifx_allgatherv_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) + _subroutine_mpifx_allgatherv_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) + _subroutine_mpifx_allgatherv_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + _subroutine_mpifx_allgatherv_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + _subroutine_mpifx_allgatherv_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + _subroutine_mpifx_allgatherv_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + _subroutine_mpifx_allgatherv_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) + _subroutine_mpifx_allgatherv_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) + _subroutine_mpifx_allgatherv_dr1(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) + _subroutine_mpifx_allgatherv_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) + _subroutine_mpifx_allgatherv_dr1(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) + _subroutine_mpifx_allgatherv_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + +end module mpifx_allgatherv_module diff --git a/src/mpifx_allgatherv.m4 b/src/mpifx_allgatherv.m4 new file mode 100644 index 0000000..aca8ecf --- /dev/null +++ b/src/mpifx_allgatherv.m4 @@ -0,0 +1,108 @@ +include(mpifx_common.m4) + +dnl ************************************************************************ +dnl *** mpifx_allgatherv +dnl ************************************************************************ + +define(`_subroutine_mpifx_allgatherv_dr0',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send/recv buffer rank (1, 2, etc.) +dnl $5: corresponding MPI type +dnl +!> Gathers results of variable length on all processes (type $1). +!! +!! \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_$1(mycomm, send, recv, recvcounts, displs, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$3 + 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), $5, recv, recvcounts, displs0, & + & $5, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_$1", error) + +end subroutine mpifx_allgatherv_$1 +') + + +define(`_subroutine_mpifx_allgatherv_dr1',`dnl +dnl +dnl $1: subroutine suffix +dnl $2: send/recv buffer type +dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) +dnl $4: send buffer size (1 or size(send)) +dnl $5: recv buffer rank specifier ((:), (:,:), etc.) +dnl $6: recv buffers rank (1, 2, etc.) +dnl $7: corresponding MPI type +dnl +!> Gathers results on one process (type $1). +!! +!! \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_$1(mycomm, send, recv, recvcounts, displs, error) + type(mpifx_comm), intent(in) :: mycomm + $2, intent(in) :: send$3 + $2, intent(out) :: recv$5 + 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=$6) == 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, $4, $7, recv, recvcounts, displs0, & + & $7, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_$1", error) + +end subroutine mpifx_allgatherv_$1 +') diff --git a/test/GNUmakefile b/test/GNUmakefile index f125633..5507bc4 100644 --- a/test/GNUmakefile +++ b/test/GNUmakefile @@ -22,8 +22,9 @@ SRCDIR = ../src .SUFFIXES: .SUFFIXES: .f90 .F90 .o .m4 -TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ - test_allreduce test_gather test_allgather test_gatherv test_scatter +TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ + test_allreduce test_gather test_gatherv test_allgather \ + test_allgatherv test_scatter all: $(TARGETS) diff --git a/test/Makefile.dep b/test/Makefile.dep index f71e27f..ffbb367 100644 --- a/test/Makefile.dep +++ b/test/Makefile.dep @@ -3,6 +3,9 @@ test_allgather.o: $$(_modobj_libmpifx_module) test_allgather.o = test_allgather.o $($(_modobj_libmpifx_module)) +test_allgatherv.o: $$(_modobj_libmpifx_module) +test_allgatherv.o = test_allgatherv.o $($(_modobj_libmpifx_module)) + test_gather.o: $$(_modobj_libmpifx_module) test_gather.o = test_gather.o $($(_modobj_libmpifx_module)) diff --git a/test/Makefile.targets b/test/Makefile.targets index 250a035..08f66bd 100644 --- a/test/Makefile.targets +++ b/test/Makefile.targets @@ -16,10 +16,13 @@ test_allreduce: $(test_allreduce.o) test_gather: $(test_gather.o) $(link-target) +test_gatherv: $(test_gatherv.o) + $(link-target) + test_allgather: $(test_allgather.o) $(link-target) -test_gatherv: $(test_gatherv.o) +test_allgatherv: $(test_allgatherv.o) $(link-target) test_scatter: $(test_scatter.o) diff --git a/test/test_allgatherv.f90 b/test/test_allgatherv.f90 new file mode 100644 index 0000000..fd44930 --- /dev/null +++ b/test/test_allgatherv.f90 @@ -0,0 +1,93 @@ +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() + + if (mycomm%size < 2) then + if (mycomm%master) then + write(*, *) 'Too few processors' + end if + end if + + ! R1 -> R1 + if (mycomm%master) 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 == 1) then + write(*, *) "Recv1 buffer:", recv1 + end if + deallocate(recvcounts) + deallocate(recv1) + + ! R2 -> R2 + if (mycomm%master) 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 == 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%master) 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 == 1) then + write(*, *) "Recv1 buffer:", recv1 + end if + + call mpifx_finalize() + +end program test_allgatherv From cf0d0427b7c92d68284d2b893b6a82ef24fa956a Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Mon, 5 Feb 2018 07:17:06 +0000 Subject: [PATCH 34/72] Last process in group printing things --- test/test_allgatherv.f90 | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/test/test_allgatherv.f90 b/test/test_allgatherv.f90 index fd44930..e3c831d 100644 --- a/test/test_allgatherv.f90 +++ b/test/test_allgatherv.f90 @@ -16,14 +16,8 @@ program test_allgatherv call mpifx_init() call mycomm%init() - if (mycomm%size < 2) then - if (mycomm%master) then - write(*, *) 'Too few processors' - end if - end if - ! R1 -> R1 - if (mycomm%master) then + if (mycomm%rank == mycomm%size - 1) then write(*, *) 'Test gather rank=1 -> rank=1' end if allocate(send1(mycomm%rank+1)) @@ -36,14 +30,14 @@ program test_allgatherv recvcounts(ii) = ii end do call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) - if (mycomm%rank == 1) then + if (mycomm%rank == mycomm%size - 1) then write(*, *) "Recv1 buffer:", recv1 end if deallocate(recvcounts) deallocate(recv1) ! R2 -> R2 - if (mycomm%master) then + if (mycomm%rank == mycomm%size - 1) then write(*, *) write(*, *) 'Test gather rank=2 -> rank=2' end if @@ -59,7 +53,7 @@ program test_allgatherv recvcounts(ii) = nCol*ii end do call mpifx_allgatherv(mycomm, send2, recv2, recvcounts) - if (mycomm%rank == 1) then + if (mycomm%rank == mycomm%size - 1) then write(*, *) "Recv2 buffer:", shape(recv2) do ii = 1, nrecv write(*,*)recv2(:,ii) @@ -69,7 +63,7 @@ program test_allgatherv ! R0 -> R1 with specified receive pattern - if (mycomm%master) then + if (mycomm%rank == mycomm%size - 1) then write(*, *) write(*, *) 'Test gather scalar -> rank=1' end if @@ -84,7 +78,7 @@ program test_allgatherv displs(ii) = mycomm%size - ii end do call mpifx_allgatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%rank == 1) then + if (mycomm%rank == mycomm%size - 1) then write(*, *) "Recv1 buffer:", recv1 end if From 99bc0c1e355986ce41797d4f6dd9ec14d061e3ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 6 Feb 2018 16:41:37 +0100 Subject: [PATCH 35/72] Update Doxygen config file --- doc/doxygen/Doxyfile | 28 ---------------------------- 1 file changed, 28 deletions(-) diff --git a/doc/doxygen/Doxyfile b/doc/doxygen/Doxyfile index cc11346..0d08f06 100644 --- a/doc/doxygen/Doxyfile +++ b/doc/doxygen/Doxyfile @@ -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 @@ -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 From 80535f850e7db0e6b95902bc16f8ca0d8ff2f514 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Fri, 23 Feb 2018 10:50:05 +0100 Subject: [PATCH 36/72] Add wrapper for mpi_init_thread --- src/mpifx_constants.F90 | 1 + src/mpifx_init.F90 | 49 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/src/mpifx_constants.F90 b/src/mpifx_constants.F90 index 3b9c723..230d17a 100644 --- a/src/mpifx_constants.F90 +++ b/src/mpifx_constants.F90 @@ -9,6 +9,7 @@ module mpifx_constants_module 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 end module mpifx_constants_module diff --git a/src/mpifx_init.F90 b/src/mpifx_init.F90 index 344304a..d974609 100644 --- a/src/mpifx_init.F90 +++ b/src/mpifx_init.F90 @@ -6,7 +6,7 @@ module mpifx_init_module implicit none private - public :: mpifx_init + public :: mpifx_init, mpifx_init_thread contains @@ -41,5 +41,52 @@ subroutine mpifx_init(error) 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, 2, 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 From 65337c7e95cea25d0375720c6c9e2051926473b3 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Sun, 25 Feb 2018 10:48:58 +0000 Subject: [PATCH 37/72] gatherv changes to allow gaps in array --- src/mpifx_gatherv.m4 | 23 ++++++++++++++++++++--- test/test_gatherv.f90 | 38 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 56 insertions(+), 5 deletions(-) diff --git a/src/mpifx_gatherv.m4 b/src/mpifx_gatherv.m4 index c7aeba5..3d43850 100644 --- a/src/mpifx_gatherv.m4 +++ b/src/mpifx_gatherv.m4 @@ -32,23 +32,40 @@ subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) integer, intent(in), optional :: root integer, intent(out), optional :: error - integer :: root0, error0, ii + integer :: root0, error0, ii, locLast(1), aborterror integer, allocatable :: displs0(:) - + logical, allocatable :: testBuffer(:) _handle_inoptflag(root0, root, mycomm%masterrank) if (mycomm%rank == root0) then - _assert(size(recv) == sum(recvcounts)) 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 diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 index cee179b..7c7318a 100644 --- a/test/test_gatherv.f90 +++ b/test/test_gatherv.f90 @@ -32,14 +32,13 @@ program test_gatherv end do else allocate(recv1(0)) - allocate(recvcounts(0)) end if call mpifx_gatherv(mycomm, send1, recv1, recvcounts) if (mycomm%master) then write(*, *) "Recv1 buffer:", recv1 deallocate(recvcounts) - deallocate(recv1) end if + deallocate(recv1) ! R2 -> R2 if (mycomm%master) then @@ -65,6 +64,7 @@ program test_gatherv write(*, *) "Recv2 buffer:", recv2(:,:) deallocate(recvcounts) end if + deallocate(recv2) ! R0 -> R1 with specified receive pattern if (mycomm%master) then @@ -82,11 +82,45 @@ program test_gatherv 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%master) then write(*, *) "Recv1 buffer:", recv1 + deallocate(recvcounts) + deallocate(displs) + end if + deallocate(recv1) + + ! R0 -> R1 with specified receive pattern including gaps + if (mycomm%master) then + write(*, *) + write(*, *) 'Test gather scalar -> rank=1' + end if + send0 = real(mycomm%rank + 1, sp) + if (mycomm%master) 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%master) then + write(*, *) "Recv1 buffer:", recv1 + deallocate(recvcounts) + deallocate(displs) end if + deallocate(recv1) call mpifx_finalize() From 099ff75161ab8b3e022114bf960b37aaf35615ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 26 Feb 2018 09:37:51 +0100 Subject: [PATCH 38/72] Introduce standardised exit codes --- src/Makefile.dep | 8 ++++---- src/mpifx_constants.F90 | 10 +++++++++- src/mpifx_helper.F90 | 5 +++-- src/mpifx_init.F90 | 6 +++++- 4 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/Makefile.dep b/src/Makefile.dep index f2b1ae4..6e9889e 100644 --- a/src/Makefile.dep +++ b/src/Makefile.dep @@ -58,8 +58,8 @@ mpifx_barrier.m4 = $(mpifx_common.m4) mpifx_recv.m4: mpifx_common.m4 mpifx_recv.m4 = $(mpifx_common.m4) -mpifx_helper.o: mpifx_helper.m4 $$(_modobj_mpi) -mpifx_helper.o = mpifx_helper.o $(mpifx_helper.m4) $($(_modobj_mpi)) +mpifx_helper.o: mpifx_helper.m4 $$(_modobj_mpi) $$(_modobj_mpifx_constants_module) +mpifx_helper.o = mpifx_helper.o $(mpifx_helper.m4) $($(_modobj_mpi)) $($(_modobj_mpifx_constants_module)) _modobj_mpifx_helper_module = mpifx_helper.o mpifx_gather.m4: mpifx_common.m4 @@ -83,8 +83,8 @@ mpifx_allgatherv.o: mpifx_allgatherv.m4 $$(_modobj_mpifx_common_module) mpifx_allgatherv.o = mpifx_allgatherv.o $(mpifx_allgatherv.m4) $($(_modobj_mpifx_common_module)) _modobj_mpifx_allgatherv_module = mpifx_allgatherv.o -mpifx_init.o: mpifx_init.m4 $$(_modobj_mpifx_common_module) -mpifx_init.o = mpifx_init.o $(mpifx_init.m4) $($(_modobj_mpifx_common_module)) +mpifx_init.o: mpifx_init.m4 $$(_modobj_mpifx_common_module) $$(_modobj_mpifx_constants_module) +mpifx_init.o = mpifx_init.o $(mpifx_init.m4) $($(_modobj_mpifx_common_module)) $($(_modobj_mpifx_constants_module)) _modobj_mpifx_init_module = mpifx_init.o mpifx_abort.m4: mpifx_common.m4 diff --git a/src/mpifx_constants.F90 b/src/mpifx_constants.F90 index 230d17a..7a565ed 100644 --- a/src/mpifx_constants.F90 +++ b/src/mpifx_constants.F90 @@ -9,7 +9,15 @@ module mpifx_constants_module 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 :: 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 diff --git a/src/mpifx_helper.F90 b/src/mpifx_helper.F90 index a160ff6..91a21de 100644 --- a/src/mpifx_helper.F90 +++ b/src/mpifx_helper.F90 @@ -4,6 +4,7 @@ !! \cond HIDDEN module mpifx_helper_module use mpi + use mpifx_constants_module implicit none private @@ -42,7 +43,7 @@ subroutine handle_errorflag(error0, msg, error) write(*, "(A)") "Operation failed!" write(*, "(A)") msg write(*, "(A,I0)") "Error: ", error0 - call mpi_abort(MPI_COMM_WORLD, -1, aborterror) + call mpi_abort(MPI_COMM_WORLD, MPIFX_UNHANDLED_ERROR, aborterror) if (aborterror /= 0) then write(*, "(A)") "Stopping code did not succeed, hope for the best." end if @@ -61,7 +62,7 @@ subroutine assertfailed(file, line) write(*, "(A)") "Assertion failed" write(*, "(A,A)") "File:", file write(*, "(A,I0)") "Line:", line - call mpi_abort(MPI_COMM_WORLD, -1, aborterror) + call mpi_abort(MPI_COMM_WORLD, MPIFX_ASSERT_FAILED, aborterror) if (aborterror /= 0) then write(*, "(A)") "Stopping code did not succeed, hope for the best." end if diff --git a/src/mpifx_init.F90 b/src/mpifx_init.F90 index d974609..187488d 100644 --- a/src/mpifx_init.F90 +++ b/src/mpifx_init.F90 @@ -3,6 +3,7 @@ !> Contains wrapper for \c MPI_INIT. module mpifx_init_module use mpifx_common_module + use mpifx_constants_module implicit none private @@ -17,6 +18,9 @@ module mpifx_init_module !! !! \see MPI documentation (\c MPI_INIT) !! + !! \note If you want to initialise MPI with threading, you should call + !! mpifx_init_thread() instead. + !! !! Example: !! !! program test_mpifx @@ -82,7 +86,7 @@ subroutine mpifx_init_thread(requiredThreading, providedThreading, error) 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, 2, error0) + 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) From 507fdf3bfcac558ec01936437ce15682bb1b8885 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Sat, 8 Dec 2018 12:57:35 +0100 Subject: [PATCH 39/72] Add cmake build system --- CMakeLists.txt | 13 +++++++++++++ src/CMakeLists.txt | 45 +++++++++++++++++++++++++++++++++++++++++++++ test/CMakeLists.txt | 15 +++++++++++++++ 3 files changed, 73 insertions(+) create mode 100644 CMakeLists.txt create mode 100644 src/CMakeLists.txt create mode 100644 test/CMakeLists.txt diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..f81a4a4 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required(VERSION 3.5) + +project(mpifx VERSION 0.1 LANGUAGES Fortran) + +set(INSTALL_BIN_DIR "bin") +set(INSTALL_MOD_DIR "include") +set(INSTALL_LIB_DIR "lib") + +find_package(MPI REQUIRED) +include_directories(SYSTEM ${MPI_Fortran_INCLUDE_PATH}) + +add_subdirectory(src) +add_subdirectory(test) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 0000000..22e42f3 --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,45 @@ +set(SOURCES-FPP + libmpifx.F90 + mpifx_abort.F90 + mpifx_allgather.F90 + mpifx_allgatherv.F90 + mpifx_allreduce.F90 + mpifx_barrier.F90 + mpifx_bcast.F90 + mpifx_comm.F90 + mpifx_common.F90 + mpifx_constants.F90 + mpifx_finalize.F90 + mpifx_gather.F90 + mpifx_gatherv.F90 + mpifx_get_processor_name.F90 + mpifx_helper.F90 + mpifx_init.F90 + mpifx_recv.F90 + mpifx_reduce.F90 + mpifx_scatter.F90 + mpifx_send.F90) + +set(SOURCES-F90-PREPROC) +foreach(fppsrc ${SOURCES-FPP}) + string(REGEX REPLACE "\\.F90" ".f90" f90src ${fppsrc}) + add_custom_command( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${f90src} + COMMAND m4 -I${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc} > ${CMAKE_CURRENT_BINARY_DIR}/${f90src} + MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc}) + list(APPEND SOURCES-F90-PREPROC ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) +endforeach() + +add_library(mpifx ${SOURCES-F90-PREPROC}) + +set(INCLUDEDIR ${CMAKE_CURRENT_BINARY_DIR}/include) + +set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${INCLUDEDIR}) + +target_include_directories(mpifx INTERFACE ${INCLUDEDIR}) + +install(TARGETS mpifx + ARCHIVE DESTINATION ${INSTALL_LIB_DIR} + LIBRARY DESTINATION ${INSTALL_LIB_DIR}) + +install(DIRECTORY ${INCLUDEDIR}/ DESTINATION ${INSTALL_MOD_DIR}) diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt new file mode 100644 index 0000000..a2b7538 --- /dev/null +++ b/test/CMakeLists.txt @@ -0,0 +1,15 @@ +set(TARGETS + test_allgather + test_allgatherv + test_allreduce + test_bcast + test_comm_split + test_gather + test_gatherv + test_reduce + test_scatter) + +foreach(target ${TARGETS}) + add_executable(${target} ${target}.f90) + target_link_libraries(${target} mpifx ${MPI_Fortran_LIBRARIES}) +endforeach() From dd82a5b7e3e4058c94e85bdcc5b1e24f5f8617cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 10 Dec 2018 16:11:59 +0100 Subject: [PATCH 40/72] Unify CMake style --- src/CMakeLists.txt | 18 +++++++++--------- test/CMakeLists.txt | 4 ++-- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 22e42f3..34795bd 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,4 +1,4 @@ -set(SOURCES-FPP +set(sources-fpp libmpifx.F90 mpifx_abort.F90 mpifx_allgather.F90 @@ -20,26 +20,26 @@ set(SOURCES-FPP mpifx_scatter.F90 mpifx_send.F90) -set(SOURCES-F90-PREPROC) -foreach(fppsrc ${SOURCES-FPP}) +set(sources-f90-preproc) +foreach(fppsrc ${sources-fpp}) string(REGEX REPLACE "\\.F90" ".f90" f90src ${fppsrc}) add_custom_command( OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${f90src} COMMAND m4 -I${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc} > ${CMAKE_CURRENT_BINARY_DIR}/${f90src} MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc}) - list(APPEND SOURCES-F90-PREPROC ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) + list(APPEND sources-f90-preproc ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) endforeach() -add_library(mpifx ${SOURCES-F90-PREPROC}) +add_library(mpifx ${sources-f90-preproc}) -set(INCLUDEDIR ${CMAKE_CURRENT_BINARY_DIR}/include) +set(includedir ${CMAKE_CURRENT_BINARY_DIR}/include) -set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${INCLUDEDIR}) +set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) -target_include_directories(mpifx INTERFACE ${INCLUDEDIR}) +target_include_directories(mpifx INTERFACE ${includedir}) install(TARGETS mpifx ARCHIVE DESTINATION ${INSTALL_LIB_DIR} LIBRARY DESTINATION ${INSTALL_LIB_DIR}) -install(DIRECTORY ${INCLUDEDIR}/ DESTINATION ${INSTALL_MOD_DIR}) +install(DIRECTORY ${includedir}/ DESTINATION ${INSTALL_MOD_DIR}) diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index a2b7538..4964663 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -1,4 +1,4 @@ -set(TARGETS +set(targets test_allgather test_allgatherv test_allreduce @@ -9,7 +9,7 @@ set(TARGETS test_reduce test_scatter) -foreach(target ${TARGETS}) +foreach(target ${targets}) add_executable(${target} ${target}.f90) target_link_libraries(${target} mpifx ${MPI_Fortran_LIBRARIES}) endforeach() From 17a8d6a799c62202c0805f4f818215265b28f2a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 17 Dec 2018 14:15:24 +0100 Subject: [PATCH 41/72] Modernise CMake loop syntax --- src/CMakeLists.txt | 3 ++- test/CMakeLists.txt | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 34795bd..eebcbf9 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -21,7 +21,8 @@ set(sources-fpp mpifx_send.F90) set(sources-f90-preproc) -foreach(fppsrc ${sources-fpp}) + +foreach(fppsrc IN LISTS sources-fpp) string(REGEX REPLACE "\\.F90" ".f90" f90src ${fppsrc}) add_custom_command( OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${f90src} diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 4964663..243a4f0 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -9,7 +9,7 @@ set(targets test_reduce test_scatter) -foreach(target ${targets}) +foreach(target IN LISTS targets) add_executable(${target} ${target}.f90) target_link_libraries(${target} mpifx ${MPI_Fortran_LIBRARIES}) endforeach() From ee15203548873bdbad12ed677b36e8bce3ef80ae Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Wed, 15 May 2019 21:36:16 +0200 Subject: [PATCH 42/72] Added SRCDIR in src/GNUmakefile --- src/GNUmakefile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/GNUmakefile b/src/GNUmakefile index 4affd8c..5113bf7 100644 --- a/src/GNUmakefile +++ b/src/GNUmakefile @@ -14,8 +14,11 @@ _FORCED_SUBMAKE_: FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ LN="$(LN)" LNOPT="$(LNOPT)" \ M4="$(M4)" M4OPT="$(M4OPT)" \ + SRCDIR="." \ -f Makefile.lib .PHONY: clean distclean clean distclean: - $(MAKE) -f Makefile.lib $@ + $(MAKE) \ + SRCDIR="." \ + -f Makefile.lib $@ From 024fc02de426f90e9e65bb013a9e49685c3ff034 Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Thu, 16 May 2019 18:11:37 +0200 Subject: [PATCH 43/72] Fix mpifx_scatter.fpp --- lib/mpifx_scatter.fpp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/mpifx_scatter.fpp b/lib/mpifx_scatter.fpp index 5e02962..848fd04 100644 --- a/lib/mpifx_scatter.fpp +++ b/lib/mpifx_scatter.fpp @@ -81,8 +81,8 @@ module mpifx_scatter_module !! end program test_scatter !! interface mpifx_scatter -#:for TYPE in INT_TYPES + FLOAT_TYPES + LOGICAL_TYPES - #:for RANK in range(1, MAX_RANK + 1) +#: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}$ @@ -113,8 +113,8 @@ contains integer :: root0, error0 - #:set SIZE = 'size(send)' - #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + #:set SIZE = 'size(recv)' + #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) @:ASSERT(.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) @:ASSERT(.not. mycomm%master& @@ -152,7 +152,7 @@ contains integer :: root0, error0 #:set SIZE = '1' if RANK == 1 else 'size(recv)' - #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) + #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) @:ASSERT(.not. mycomm%master .or. size(send) == ${SIZE}$ * mycomm%size) @:ASSERT(.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%size) From 113529edc757a98f3c5144dc5fa6a026cf399bd8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Thu, 8 Aug 2019 17:42:29 +0200 Subject: [PATCH 44/72] Add possibility of object library creation --- src/CMakeLists.txt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index eebcbf9..0c4db82 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -31,13 +31,16 @@ foreach(fppsrc IN LISTS sources-fpp) list(APPEND sources-f90-preproc ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) endforeach() -add_library(mpifx ${sources-f90-preproc}) +add_library(mpifx_objlib OBJECT ${sources-f90-preproc}) +add_library(mpifx $) set(includedir ${CMAKE_CURRENT_BINARY_DIR}/include) -set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) +set_target_properties(mpifx_objlib PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) -target_include_directories(mpifx INTERFACE ${includedir}) +target_include_directories(mpifx_objlib INTERFACE ${includedir}) +target_include_directories(mpifx INTERFACE + $) install(TARGETS mpifx ARCHIVE DESTINATION ${INSTALL_LIB_DIR} From 9b29d660423398388225853ebf79337f33db37f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Fri, 9 Aug 2019 09:38:02 +0200 Subject: [PATCH 45/72] Make CMakeLists.txt Nag compatible --- src/CMakeLists.txt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 0c4db82..129e203 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -38,9 +38,8 @@ set(includedir ${CMAKE_CURRENT_BINARY_DIR}/include) set_target_properties(mpifx_objlib PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) -target_include_directories(mpifx_objlib INTERFACE ${includedir}) -target_include_directories(mpifx INTERFACE - $) +target_include_directories(mpifx_objlib PUBLIC ${includedir}) +target_include_directories(mpifx PUBLIC ${includedir}) install(TARGETS mpifx ARCHIVE DESTINATION ${INSTALL_LIB_DIR} From acc48b091bdcb1561e0266b171c418a20c6a2b4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Sat, 10 Aug 2019 21:02:20 +0200 Subject: [PATCH 46/72] Add '-mismatch' for NAG compiler --- src/CMakeLists.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 129e203..2086efb 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -31,6 +31,11 @@ foreach(fppsrc IN LISTS sources-fpp) list(APPEND sources-f90-preproc ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) endforeach() +# NAG compiler won't compile this files without the '-mismatch' option +if("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "NAG") + set_source_files_properties(SOURCE ${sources-f90-preproc} PROPERTY COMPILE_FLAGS -mismatch) +endif() + add_library(mpifx_objlib OBJECT ${sources-f90-preproc}) add_library(mpifx $) From 20eb02d24676703596e8766a56e8c0082332a6cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 13 Aug 2019 19:53:03 +0200 Subject: [PATCH 47/72] Remove obsolete CMake directive --- CMakeLists.txt | 1 - 1 file changed, 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index f81a4a4..0eff615 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -7,7 +7,6 @@ set(INSTALL_MOD_DIR "include") set(INSTALL_LIB_DIR "lib") find_package(MPI REQUIRED) -include_directories(SYSTEM ${MPI_Fortran_INCLUDE_PATH}) add_subdirectory(src) add_subdirectory(test) From 639632f310485ffdd129365f08fc2c106017b21a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 14 Aug 2019 16:56:10 +0200 Subject: [PATCH 48/72] Add library only build and overridable installation paths --- CMakeLists.txt | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 0eff615..a3bbb40 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,11 +2,24 @@ cmake_minimum_required(VERSION 3.5) project(mpifx VERSION 0.1 LANGUAGES Fortran) -set(INSTALL_BIN_DIR "bin") -set(INSTALL_MOD_DIR "include") -set(INSTALL_LIB_DIR "lib") +set(LIBRARY_ONLY FALSE CACHE BOOL "Whether only library should be compiled") + +# Installation paths +set(INSTALL_BIN_DIR "${CMAKE_INSTALL_PREFIX}/bin" CACHE PATH + "Installation directory for executables") + +set(INSTALL_LIB_DIR "${CMAKE_INSTALL_PREFIX}/lib" CACHE PATH + "Installation directory for libraries") + +set(INSTALL_MOD_DIR "${CMAKE_INSTALL_PREFIX}/include/dftd3" CACHE PATH + "Installation directory for Fortran module files") + +set(INSTALL_CMAKE_DIR "${CMAKE_INSTALL_PREFIX}/lib/cmake" CACHE PATH + "Installation directory for CMake package export files") find_package(MPI REQUIRED) add_subdirectory(src) -add_subdirectory(test) +if(NOT LIBRARY_ONLY) + add_subdirectory(test) +endif() From 9354f5dff0a72042162a865171dd69cbacda51e2 Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Thu, 22 Aug 2019 13:58:44 +0200 Subject: [PATCH 49/72] Minor fixes for dftb+ compilation --- lib/make.deps | 17 ++++++----- lib/mpifx_abort.fpp | 14 ++++----- lib/mpifx_constants.fpp | 13 ++++++-- lib/mpifx_get_processor_name.fpp | 5 ++-- lib/mpifx_init.fpp | 51 ++++++++++++++++++++++++++++++-- 5 files changed, 78 insertions(+), 22 deletions(-) diff --git a/lib/make.deps b/lib/make.deps index f7c42f3..1d1ebe9 100644 --- a/lib/make.deps +++ b/lib/make.deps @@ -8,10 +8,6 @@ mpifx_recv.o: $$(_modobj_mpifx_common_module) mpifx_recv.o = mpifx_recv.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_recv_module = mpifx_recv.o -mpifx_get_processor_name.o: $$(_modobj_mpifx_common) -mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpifx_common)) -_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o - mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_gather_module = mpifx_gather.o @@ -28,20 +24,21 @@ mpifx_allgather.o: $$(_modobj_mpifx_common_module) mpifx_allgather.o = mpifx_allgather.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_allgather_module = mpifx_allgather.o -mpifx_constants.o: $$(_modobj_mpifx_common) -mpifx_constants.o = mpifx_constants.o $($(_modobj_mpifx_common)) +mpifx_constants.o: $$(_modobj_mpifx_common_module) +mpifx_constants.o = mpifx_constants.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_constants_module = mpifx_constants.o module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) + _modobj_libmpifx_module = module.o mpifx_allreduce.o: $$(_modobj_mpifx_common_module) mpifx_allreduce.o = mpifx_allreduce.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_allreduce_module = mpifx_allreduce.o -mpifx_init.o: $$(_modobj_mpifx_common_module) -mpifx_init.o = mpifx_init.o $($(_modobj_mpifx_common_module)) +mpifx_init.o: $$(_modobj_mpifx_common_module) $$(_modobj_mpifx_constants_module) +mpifx_init.o = mpifx_init.o $($(_modobj_mpifx_common_module)) $($(_modobj_mpifx_constants_module)) _modobj_mpifx_init_module = mpifx_init.o mpifx_common.o: $$(_modobj_mpifx_helper_module) $$(_modobj_mpi) $$(_modobj_mpifx_comm_module) @@ -72,3 +69,7 @@ mpifx_bcast.o: $$(_modobj_mpifx_common_module) mpifx_bcast.o = mpifx_bcast.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_bcast_module = mpifx_bcast.o +mpifx_get_processor_name.o: $$(_modobj_mpifx_common_module) +mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o + diff --git a/lib/mpifx_abort.fpp b/lib/mpifx_abort.fpp index fe73917..0d7203f 100644 --- a/lib/mpifx_abort.fpp +++ b/lib/mpifx_abort.fpp @@ -1,4 +1,4 @@ -!> Contains wrapper for \c MPI_ABORT. +!> Contains wrapper for \c MPI_ABORT. module mpifx_abort_module use mpifx_common_module implicit none @@ -36,20 +36,18 @@ contains 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 + errorcode0 = -1 end if + call mpi_abort(mycomm%id, errorcode0, error0) - if (present(error)) then - error = error0 - end if - - end subroutine mpifx_abort + call handle_errorflag(error0, "MPI_ABORT in mpifx_abort", error) + end subroutine mpifx_abort end module mpifx_abort_module diff --git a/lib/mpifx_constants.fpp b/lib/mpifx_constants.fpp index f2ba3f4..c133034 100644 --- a/lib/mpifx_constants.fpp +++ b/lib/mpifx_constants.fpp @@ -1,13 +1,22 @@ !> Exports some MPI constants. !! \cond HIDDEN module mpifx_constants_module - use mpifx_common_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_get_processor_name.fpp b/lib/mpifx_get_processor_name.fpp index aabe73a..7e274b6 100644 --- a/lib/mpifx_get_processor_name.fpp +++ b/lib/mpifx_get_processor_name.fpp @@ -1,6 +1,7 @@ !> Contains the extended MPI communicator. module mpifx_get_processor_name_module - use mpifx_common_module + use mpifx_helper_module + use mpi implicit none private @@ -27,7 +28,7 @@ contains end if rankname = buffer(1:length) - end subroutine mpifx_get_processor_name + end subroutine mpifx_get_processor_name end module mpifx_get_processor_name_module diff --git a/lib/mpifx_init.fpp b/lib/mpifx_init.fpp index e165941..fb78434 100644 --- a/lib/mpifx_init.fpp +++ b/lib/mpifx_init.fpp @@ -1,10 +1,11 @@ !> Contains wrapper for \c MPI_INIT. module mpifx_init_module use mpifx_common_module + use mpifx_constants_module implicit none private - public :: mpifx_init + public :: mpifx_init, mpifx_init_thread contains @@ -39,5 +40,51 @@ contains 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 From 26882a0a59a3f32dde8efd47b8f8687a2fe4cf81 Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Thu, 22 Aug 2019 18:21:16 +0200 Subject: [PATCH 50/72] Update mpifx.fypp, mpifx_helper.fpp and mpifx_init.fpp --- lib/mpifx.fypp | 49 ++++++++++++++++++--- lib/mpifx_helper.fpp | 22 +++++----- lib/mpifx_init.fpp | 1 + src/mpifx_constants.F90 | 24 ----------- src/mpifx_helper.F90 | 75 -------------------------------- src/mpifx_init.F90 | 96 ----------------------------------------- 6 files changed, 56 insertions(+), 211 deletions(-) delete mode 100644 src/mpifx_constants.F90 delete mode 100644 src/mpifx_helper.F90 delete mode 100644 src/mpifx_init.F90 diff --git a/lib/mpifx.fypp b/lib/mpifx.fypp index eb708c7..1c7c95e 100644 --- a/lib/mpifx.fypp +++ b/lib/mpifx.fypp @@ -1,5 +1,5 @@ #:mute - + #! Set DEBUG to 0 unless DEBUG level is specified explicitely #:set DEBUG = getvar('DEBUG', 0) @@ -17,7 +17,7 @@ #: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'} @@ -38,9 +38,9 @@ #! 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. +#! if RANK is zero. #:def RANKSUFFIX(RANK) ${'' if RANK == 0 else '(' + ':' + ',:' * (RANK - 1) +')'}$ #:enddef RANKSUFFIX @@ -49,7 +49,7 @@ ${'' if RANK == 0 else '(' + ':' + ',:' * (RANK - 1) +')'}$ #! Indicates debug code. #! #! code: Code to insert, if DEBUG > 0 -#! +#! #:def DEBUG_CODE(code) #:if DEBUG > 0 $:code @@ -69,4 +69,43 @@ 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 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_helper.fpp b/lib/mpifx_helper.fpp index 98e826b..61b84e0 100644 --- a/lib/mpifx_helper.fpp +++ b/lib/mpifx_helper.fpp @@ -4,8 +4,8 @@ !> Exports constants and helper routine(s). !! \cond HIDDEN module mpifx_helper_module - use, intrinsic :: iso_fortran_env, only : stderr => error_unit use mpi + use mpifx_constants_module implicit none private @@ -22,10 +22,10 @@ module mpifx_helper_module !> Double precision kind. integer, parameter :: dp = kind(1.0d0) - + interface getoptarg #:for RANK in OPT_ARG_RANKS - #:for TYPE in ALL_TYPES + #:for TYPE in ALL_TYPES module procedure getoptarg_${TYPE_ABBREVS[TYPE]}$${RANK}$ #:endfor #:endfor @@ -34,13 +34,13 @@ module mpifx_helper_module interface setoptarg #:for RANK in OPT_ARG_RANKS - #:for TYPE in ALL_TYPES + #:for TYPE in ALL_TYPES module procedure setoptarg_${TYPE_ABBREVS[TYPE]}$${RANK}$ #:endfor #:endfor end interface setoptarg - + contains !> Handles optional error flag. @@ -52,7 +52,7 @@ contains !> 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 @@ -61,14 +61,14 @@ contains 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, 1, aborterror) + 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 @@ -89,12 +89,12 @@ contains write(stderr, "(A)") "Assertion failed" write(stderr, "(A,A)") "File:", file write(stderr, "(A,I0)") "Line:", line - call mpi_abort(MPI_COMM_WORLD, 1, aborterror) + 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 @@ -146,7 +146,7 @@ contains #:endfor #:endfor - + end module mpifx_helper_module !> \endcond diff --git a/lib/mpifx_init.fpp b/lib/mpifx_init.fpp index fb78434..387b758 100644 --- a/lib/mpifx_init.fpp +++ b/lib/mpifx_init.fpp @@ -87,4 +87,5 @@ contains end subroutine mpifx_init_thread + end module mpifx_init_module diff --git a/src/mpifx_constants.F90 b/src/mpifx_constants.F90 deleted file mode 100644 index 7a565ed..0000000 --- a/src/mpifx_constants.F90 +++ /dev/null @@ -1,24 +0,0 @@ -include(mpifx_constants.m4) - -!> 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/src/mpifx_helper.F90 b/src/mpifx_helper.F90 deleted file mode 100644 index 91a21de..0000000 --- a/src/mpifx_helper.F90 +++ /dev/null @@ -1,75 +0,0 @@ -include(mpifx_helper.m4) - -!> Exports constants and helper routine(s). -!! \cond HIDDEN -module mpifx_helper_module - use mpi - use mpifx_constants_module - implicit none - private - - public :: default_tag, sp, dp - public :: handle_errorflag, assertfailed - - !> 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) - -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 - - integer :: aborterror - - if (present(error)) then - error = error0 - elseif (error0 /= 0) then - write(*, "(A)") "Operation failed!" - write(*, "(A)") msg - write(*, "(A,I0)") "Error: ", error0 - call mpi_abort(MPI_COMM_WORLD, MPIFX_UNHANDLED_ERROR, aborterror) - if (aborterror /= 0) then - write(*, "(A)") "Stopping code did not succeed, hope for the best." - end if - end if - - end subroutine handle_errorflag - - - !> Stops code signalizing failed a - subroutine assertfailed(file, line) - character(*), intent(in) :: file - integer, intent(in) :: line - - integer :: aborterror - - write(*, "(A)") "Assertion failed" - write(*, "(A,A)") "File:", file - write(*, "(A,I0)") "Line:", line - call mpi_abort(MPI_COMM_WORLD, MPIFX_ASSERT_FAILED, aborterror) - if (aborterror /= 0) then - write(*, "(A)") "Stopping code did not succeed, hope for the best." - end if - - end subroutine assertfailed - - -end module mpifx_helper_module - -!> \endcond diff --git a/src/mpifx_init.F90 b/src/mpifx_init.F90 deleted file mode 100644 index 187488d..0000000 --- a/src/mpifx_init.F90 +++ /dev/null @@ -1,96 +0,0 @@ -include(mpifx_init.m4) - -!> 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) - !! - !! \note If you want to initialise MPI with threading, you should call - !! mpifx_init_thread() instead. - !! - !! 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 From 526024d9e60725dcda2b4a8ba5769502dd8691dd Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Thu, 22 Aug 2019 20:25:25 +0200 Subject: [PATCH 51/72] Update mpifx.fypp --- lib/mpifx.fypp | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lib/mpifx.fypp b/lib/mpifx.fypp index 1c7c95e..68e76bb 100644 --- a/lib/mpifx.fypp +++ b/lib/mpifx.fypp @@ -99,6 +99,19 @@ end if #: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) From d229b666d7a757b775c89729aabeba92428125fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 26 Aug 2019 15:07:15 +0200 Subject: [PATCH 52/72] Add option to prevent include file installation --- CMakeLists.txt | 4 ++++ src/CMakeLists.txt | 10 +++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index a3bbb40..dacab1c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -17,6 +17,10 @@ set(INSTALL_MOD_DIR "${CMAKE_INSTALL_PREFIX}/include/dftd3" CACHE PATH set(INSTALL_CMAKE_DIR "${CMAKE_INSTALL_PREFIX}/lib/cmake" CACHE PATH "Installation directory for CMake package export files") +option(BUILD_SHARED_LIBS "Whether the library should be shared" FALSE) + +option(INSTALL_INCLUDE_FILES "Whether include and module files should be installed" TRUE) + find_package(MPI REQUIRED) add_subdirectory(src) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 2086efb..3e6ea7d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -36,18 +36,18 @@ if("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "NAG") set_source_files_properties(SOURCE ${sources-f90-preproc} PROPERTY COMPILE_FLAGS -mismatch) endif() -add_library(mpifx_objlib OBJECT ${sources-f90-preproc}) -add_library(mpifx $) +add_library(mpifx ${sources-f90-preproc}) set(includedir ${CMAKE_CURRENT_BINARY_DIR}/include) -set_target_properties(mpifx_objlib PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) +set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) -target_include_directories(mpifx_objlib PUBLIC ${includedir}) target_include_directories(mpifx PUBLIC ${includedir}) install(TARGETS mpifx ARCHIVE DESTINATION ${INSTALL_LIB_DIR} LIBRARY DESTINATION ${INSTALL_LIB_DIR}) -install(DIRECTORY ${includedir}/ DESTINATION ${INSTALL_MOD_DIR}) +if(INSTALL_INCLUDE_FILES) + install(DIRECTORY ${includedir}/ DESTINATION ${INSTALL_MOD_DIR}) +endif() From 8c647745c7d9807e593c0dc62579a4e79d92fe85 Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Tue, 27 Aug 2019 17:08:21 +0200 Subject: [PATCH 53/72] Merged fypp version of mpifx into master --- lib/make.deps | 20 ++- lib/module.fpp | 16 +- lib/mpifx_allgatherv.fpp | 271 ++++++++++++++++++++++++++++++++++ lib/mpifx_gatherv.fpp | 305 +++++++++++++++++++++++++++++++++++++++ lib/mpifx_helper.fpp | 2 +- 5 files changed, 599 insertions(+), 15 deletions(-) create mode 100644 lib/mpifx_allgatherv.fpp create mode 100644 lib/mpifx_gatherv.fpp diff --git a/lib/make.deps b/lib/make.deps index 1d1ebe9..34e8f62 100644 --- a/lib/make.deps +++ b/lib/make.deps @@ -1,7 +1,7 @@ .SECONDEXPANSION: -mpifx_helper.o: $$(_modobj_mpi) -mpifx_helper.o = mpifx_helper.o $($(_modobj_mpi)) +mpifx_helper.o: $$(_modobj_mpi) $$(_modobj_mpifx_constants_module) +mpifx_helper.o = mpifx_helper.o $($(_modobj_mpi)) $($(_modobj_mpifx_constants_module)) _modobj_mpifx_helper_module = mpifx_helper.o mpifx_recv.o: $$(_modobj_mpifx_common_module) @@ -12,6 +12,10 @@ mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_gather_module = mpifx_gather.o +mpifx_gatherv.o: $$(_modobj_mpifx_common_module) +mpifx_gatherv.o = mpifx_gatherv.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_gatherv_module = mpifx_gatherv.o + mpifx_finalize.o: $$(_modobj_mpifx_common_module) mpifx_finalize.o = mpifx_finalize.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_finalize_module = mpifx_finalize.o @@ -24,12 +28,16 @@ mpifx_allgather.o: $$(_modobj_mpifx_common_module) mpifx_allgather.o = mpifx_allgather.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_allgather_module = mpifx_allgather.o -mpifx_constants.o: $$(_modobj_mpifx_common_module) -mpifx_constants.o = mpifx_constants.o $($(_modobj_mpifx_common_module)) +mpifx_allgatherv.o: $$(_modobj_mpifx_common_module) +mpifx_allgatherv.o = mpifx_allgatherv.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_allgatherv_module = mpifx_allgatherv.o + +mpifx_constants.o: $$(_modobj_mpi) +mpifx_constants.o = mpifx_constants.o $($(_modobj_mpi)) _modobj_mpifx_constants_module = mpifx_constants.o -module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_allgatherv_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_allgatherv_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) _modobj_libmpifx_module = module.o diff --git a/lib/module.fpp b/lib/module.fpp index 8881bc4..72e644c 100644 --- a/lib/module.fpp +++ b/lib/module.fpp @@ -1,25 +1,25 @@ !> \mainpage Modern Fortran wrappers around MPI routines !! -<<<<<<< HEAD:lib/module.fpp +!!<<<<<<< HEAD:lib/module.fpp !! The open source library [MPIFX](https://www.bitbucket.org/dftbplus/mpifx) is -======= +!!======= !! The open source library [MPIFX](https://github.com/dftbplus/mpifx) is ->>>>>>> master:src/libmpifx.F90 +!!>>>>>>> master:src/libmpifx.F90 !! 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: -<<<<<<< HEAD:lib/module.fpp +!!<<<<<<< HEAD:lib/module.fpp !! * [Online documentation](https://dftbplus.bitbucket.org/mpifx/) !! for installation and usage of the library !! * [API documentation](annotated.html) for the reference manual. !! * [Project home page](https://www.bitbucket.org/dftbplus/mpifx/) -======= +!!======= !! * [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) ->>>>>>> master:src/libmpifx.F90 +!!>>>>>>> master:src/libmpifx.F90 !! for the source code, bug tracker and further information on the project. !! module libmpifx_module @@ -42,5 +42,5 @@ module libmpifx_module use mpifx_scatter_module implicit none public - + end module libmpifx_module diff --git a/lib/mpifx_allgatherv.fpp b/lib/mpifx_allgatherv.fpp new file mode 100644 index 0000000..2759dfa --- /dev/null +++ b/lib/mpifx_allgatherv.fpp @@ -0,0 +1,271 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES + + +#! ************************************************************************ +#! *** mpifx_allgatherv +#! ************************************************************************ + + +#:def mpifx_allgatherv_dr0_template(VAR1, VAR2, VAR3, VAR4, VAR5) +#! + #! + #! ${VAR1}$: subroutine suffix + #! ${VAR2}$: send/recv buffer type + #! ${VAR3}$: send/recv buffer rank specifier ("", (:), (:,:), etc.) + #! ${VAR4}$: send/recv buffer rank (1, 2, etc.) + #! ${VAR5}$: corresponding MPI type + #! + !> Gathers results of variable length on all processes (type ${VAR1}$). + !! + !! \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_${VAR1}$(mycomm, send, recv, recvcounts, displs, error) + type(mpifx_comm), intent(in) :: mycomm + ${VAR2}$, intent(in) :: send${VAR3}$ + ${VAR2}$, intent(out) :: recv${VAR3}$ + 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), ${VAR5}$, recv, recvcounts, displs0, & + & ${VAR5}$, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_${VAR1}$", error) + + end subroutine mpifx_allgatherv_${VAR1}$ + +#:enddef + + + +#:def mpifx_allgatherv_dr1_template(VAR1, VAR2, VAR3, VAR4, VAR5, VAR6, VAR7) +#! + #! + #! ${VAR1}$: subroutine suffix + #! ${VAR2}$: send/recv buffer type + #! ${VAR3}$: send buffer rank specifier ("", (:), (:,:), etc.) + #! ${VAR4}$: send buffer size (1 or size(send)) + #! ${VAR5}$: recv buffer rank specifier ((:), (:,:), etc.) + #! ${VAR6}$: recv buffers rank (1, 2, etc.) + #! ${VAR7}$: corresponding MPI type + #! + !> Gathers results on one process (type ${VAR1}$). + !! + !! \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_${VAR1}$(mycomm, send, recv, recvcounts, displs, error) + type(mpifx_comm), intent(in) :: mycomm + ${VAR2}$, intent(in) :: send${VAR3}$ + ${VAR2}$, intent(out) :: recv${VAR5}$ + 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=${VAR6}$) == 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, ${VAR4}$, ${VAR7}$, recv, recvcounts, displs0, & + & ${VAR7}$, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_${VAR1}$", error) + + end subroutine mpifx_allgatherv_${VAR1}$ + +#: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%master) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_allgatherv + !! + interface mpifx_allgatherv + module procedure & + & mpifx_allgatherv_i1i1, mpifx_allgatherv_i2i2, mpifx_allgatherv_i3i3, & + & mpifx_allgatherv_i4i4, mpifx_allgatherv_i5i5, mpifx_allgatherv_i6i6 + module procedure & + & mpifx_allgatherv_i0i1 + module procedure & + & mpifx_allgatherv_s1s1, mpifx_allgatherv_s2s2, mpifx_allgatherv_s3s3, & + & mpifx_allgatherv_s4s4, mpifx_allgatherv_s5s5, mpifx_allgatherv_s6s6 + module procedure & + & mpifx_allgatherv_s0s1 + module procedure & + & mpifx_allgatherv_d1d1, mpifx_allgatherv_d2d2, mpifx_allgatherv_d3d3, & + & mpifx_allgatherv_d4d4, mpifx_allgatherv_d5d5, mpifx_allgatherv_d6d6 + module procedure & + & mpifx_allgatherv_d0d1 + module procedure & + & mpifx_allgatherv_c1c1, mpifx_allgatherv_c2c2, mpifx_allgatherv_c3c3, & + & mpifx_allgatherv_c4c4, mpifx_allgatherv_c5c5, mpifx_allgatherv_c6c6 + module procedure & + & mpifx_allgatherv_c0c1 + module procedure & + & mpifx_allgatherv_z1z1, mpifx_allgatherv_z2z2, mpifx_allgatherv_z3z3, & + & mpifx_allgatherv_z4z4, mpifx_allgatherv_z5z5, mpifx_allgatherv_z6z6 + module procedure & + & mpifx_allgatherv_z0z1 + module procedure & + & mpifx_allgatherv_l1l1, mpifx_allgatherv_l2l2, mpifx_allgatherv_l3l3, & + & mpifx_allgatherv_l4l4, mpifx_allgatherv_l5l5, mpifx_allgatherv_l6l6 + module procedure & + & mpifx_allgatherv_l0l1 + end interface mpifx_allgatherv + + +contains + + @:mpifx_allgatherv_dr0_template(i1i1, integer, (:), 1, MPI_INTEGER) + @:mpifx_allgatherv_dr0_template(i2i2, integer, (:,:), 2, MPI_INTEGER) + @:mpifx_allgatherv_dr0_template(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + @:mpifx_allgatherv_dr0_template(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + @:mpifx_allgatherv_dr0_template(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + @:mpifx_allgatherv_dr0_template(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + + @:mpifx_allgatherv_dr0_template(s1s1, real(sp), (:), 1, MPI_REAL) + @:mpifx_allgatherv_dr0_template(s2s2, real(sp), (:,:), 2, MPI_REAL) + @:mpifx_allgatherv_dr0_template(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + @:mpifx_allgatherv_dr0_template(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + @:mpifx_allgatherv_dr0_template(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + @:mpifx_allgatherv_dr0_template(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + + @:mpifx_allgatherv_dr0_template(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + @:mpifx_allgatherv_dr0_template(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) + @:mpifx_allgatherv_dr0_template(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) + @:mpifx_allgatherv_dr0_template(d4d4, real(dp), (:,:,:,:), 4, MPI_DOUBLE_PRECISION) + @:mpifx_allgatherv_dr0_template(d5d5, real(dp), (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) + @:mpifx_allgatherv_dr0_template(d6d6, real(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) + + + @:mpifx_allgatherv_dr0_template(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + @:mpifx_allgatherv_dr0_template(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + @:mpifx_allgatherv_dr0_template(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + @:mpifx_allgatherv_dr0_template(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + @:mpifx_allgatherv_dr0_template(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) + @:mpifx_allgatherv_dr0_template(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + @:mpifx_allgatherv_dr0_template(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + @:mpifx_allgatherv_dr0_template(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) + @:mpifx_allgatherv_dr0_template(z3z3, complex(dp), (:,:,:), 3, MPI_DOUBLE_COMPLEX) + @:mpifx_allgatherv_dr0_template(z4z4, complex(dp), (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) + @:mpifx_allgatherv_dr0_template(z5z5, complex(dp), (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) + @:mpifx_allgatherv_dr0_template(z6z6, complex(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) + + + @:mpifx_allgatherv_dr0_template(l1l1, logical, (:), 1, MPI_LOGICAL) + @:mpifx_allgatherv_dr0_template(l2l2, logical, (:,:), 2, MPI_LOGICAL) + @:mpifx_allgatherv_dr0_template(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + @:mpifx_allgatherv_dr0_template(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + @:mpifx_allgatherv_dr0_template(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + @:mpifx_allgatherv_dr0_template(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + @:mpifx_allgatherv_dr1_template(i0i1, integer, , 1, (:), 1, MPI_INTEGER) + @:mpifx_allgatherv_dr1_template(s0s1, real(sp), , 1, (:), 1, MPI_REAL) + @:mpifx_allgatherv_dr1_template(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) + @:mpifx_allgatherv_dr1_template(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) + @:mpifx_allgatherv_dr1_template(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) + @:mpifx_allgatherv_dr1_template(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + +end module mpifx_allgatherv_module diff --git a/lib/mpifx_gatherv.fpp b/lib/mpifx_gatherv.fpp new file mode 100644 index 0000000..c4005a7 --- /dev/null +++ b/lib/mpifx_gatherv.fpp @@ -0,0 +1,305 @@ +#:include 'mpifx.fypp' +#:set TYPES = ALL_TYPES + + +#! ************************************************************************ +#! *** mpifx_gatherv +#! ************************************************************************ + + +#:def mpifx_gatherv_dr0_template(VAR1, VAR2, VAR3, VAR4, VAR5) +#! + #! + #! ${VAR1}$: subroutine suffix + #! ${VAR2}$: send/recv buffer type + #! ${VAR3}$: send/recv buffer rank specifier ("", (:), (:,:), etc.) + #! ${VAR4}$: send/recv buffer rank (1, 2, etc.) + #! ${VAR5}$: corresponding MPI type + #! + !> Gathers results of variable length on one process (type ${VAR1}$). + !! + !! \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%masterrank) + !! \param error Error code on exit. + !! + subroutine mpifx_gatherv_${VAR1}$(mycomm, send, recv, recvcounts, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${VAR2}$, intent(in) :: send${VAR3}$ + ${VAR2}$, intent(out) :: recv${VAR3}$ + 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%masterrank) + + 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), ${VAR5}$, recv, recvcounts, displs0, & + & ${VAR5}$, root0, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_${VAR1}$", error) + + end subroutine mpifx_gatherv_${VAR1}$ + +#:enddef + + + +#:def mpifx_gatherv_dr1_template(VAR1, VAR2, VAR3, VAR4, VAR5, VAR6, VAR7) +#! + #! + #! ${VAR1}$: subroutine suffix + #! ${VAR2}$: send/recv buffer type + #! ${VAR3}$: send buffer rank specifier ("", (:), (:,:), etc.) + #! ${VAR4}$: send buffer size (1 or size(send)) + #! ${VAR5}$: recv buffer rank specifier ((:), (:,:), etc.) + #! ${VAR6}$: recv buffers rank (1, 2, etc.) + #! ${VAR7}$: corresponding MPI type + #! + !> Gathers results on one process (type ${VAR1}$). + !! + !! \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%masterrank) + !! \param error Error code on exit. + !! + subroutine mpifx_gatherv_${VAR1}$(mycomm, send, recv, recvcounts, displs, root, error) + type(mpifx_comm), intent(in) :: mycomm + ${VAR2}$, intent(in) :: send${VAR3}$ + ${VAR2}$, intent(out) :: recv${VAR5}$ + 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%masterrank) + + if (mycomm%rank == root0) then + @:ASSERT(size(recv) == sum(recvcounts)) + @:ASSERT(size(recv, dim=${VAR6}$) == 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, ${VAR4}$, ${VAR7}$, recv, recvcounts, displs0, & + & ${VAR7}$, root0, mycomm%id, error0) + + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_${VAR1}$", error) + + end subroutine mpifx_gatherv_${VAR1}$ + +#: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%master) 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%master) then + !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 + !! end if + !! + !! call mpifx_finalize() + !! + !! end program test_gatherv + !! + interface mpifx_gatherv + module procedure & + & mpifx_gatherv_i1i1, mpifx_gatherv_i2i2, mpifx_gatherv_i3i3, & + & mpifx_gatherv_i4i4, mpifx_gatherv_i5i5, mpifx_gatherv_i6i6 + module procedure & + & mpifx_gatherv_i0i1 + module procedure & + & mpifx_gatherv_s1s1, mpifx_gatherv_s2s2, mpifx_gatherv_s3s3, & + & mpifx_gatherv_s4s4, mpifx_gatherv_s5s5, mpifx_gatherv_s6s6 + module procedure & + & mpifx_gatherv_s0s1 + module procedure & + & mpifx_gatherv_d1d1, mpifx_gatherv_d2d2, mpifx_gatherv_d3d3, & + & mpifx_gatherv_d4d4, mpifx_gatherv_d5d5, mpifx_gatherv_d6d6 + module procedure & + & mpifx_gatherv_d0d1 + module procedure & + & mpifx_gatherv_c1c1, mpifx_gatherv_c2c2, mpifx_gatherv_c3c3, & + & mpifx_gatherv_c4c4, mpifx_gatherv_c5c5, mpifx_gatherv_c6c6 + module procedure & + & mpifx_gatherv_c0c1 + module procedure & + & mpifx_gatherv_z1z1, mpifx_gatherv_z2z2, mpifx_gatherv_z3z3, & + & mpifx_gatherv_z4z4, mpifx_gatherv_z5z5, mpifx_gatherv_z6z6 + module procedure & + & mpifx_gatherv_z0z1 + module procedure & + & mpifx_gatherv_l1l1, mpifx_gatherv_l2l2, mpifx_gatherv_l3l3, & + & mpifx_gatherv_l4l4, mpifx_gatherv_l5l5, mpifx_gatherv_l6l6 + module procedure & + & mpifx_gatherv_l0l1 + end interface mpifx_gatherv + + +contains + + @:mpifx_gatherv_dr0_template(i1i1, integer, (:), 1, MPI_INTEGER) + @:mpifx_gatherv_dr0_template(i2i2, integer, (:,:), 2, MPI_INTEGER) + @:mpifx_gatherv_dr0_template(i3i3, integer, (:,:,:), 3, MPI_INTEGER) + @:mpifx_gatherv_dr0_template(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) + @:mpifx_gatherv_dr0_template(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) + @:mpifx_gatherv_dr0_template(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) + + + @:mpifx_gatherv_dr0_template(s1s1, real(sp), (:), 1, MPI_REAL) + @:mpifx_gatherv_dr0_template(s2s2, real(sp), (:,:), 2, MPI_REAL) + @:mpifx_gatherv_dr0_template(s3s3, real(sp), (:,:,:), 3, MPI_REAL) + @:mpifx_gatherv_dr0_template(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) + @:mpifx_gatherv_dr0_template(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) + @:mpifx_gatherv_dr0_template(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) + + + @:mpifx_gatherv_dr0_template(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) + @:mpifx_gatherv_dr0_template(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) + @:mpifx_gatherv_dr0_template(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) + @:mpifx_gatherv_dr0_template(d4d4, real(dp), (:,:,:,:), 4, MPI_DOUBLE_PRECISION) + @:mpifx_gatherv_dr0_template(d5d5, real(dp), (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) + @:mpifx_gatherv_dr0_template(d6d6, real(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) + + + @:mpifx_gatherv_dr0_template(c1c1, complex(sp), (:), 1, MPI_COMPLEX) + @:mpifx_gatherv_dr0_template(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) + @:mpifx_gatherv_dr0_template(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) + @:mpifx_gatherv_dr0_template(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) + @:mpifx_gatherv_dr0_template(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) + @:mpifx_gatherv_dr0_template(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) + + + @:mpifx_gatherv_dr0_template(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) + @:mpifx_gatherv_dr0_template(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) + @:mpifx_gatherv_dr0_template(z3z3, complex(dp), (:,:,:), 3, MPI_DOUBLE_COMPLEX) + @:mpifx_gatherv_dr0_template(z4z4, complex(dp), (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) + @:mpifx_gatherv_dr0_template(z5z5, complex(dp), (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) + @:mpifx_gatherv_dr0_template(z6z6, complex(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) + + + @:mpifx_gatherv_dr0_template(l1l1, logical, (:), 1, MPI_LOGICAL) + @:mpifx_gatherv_dr0_template(l2l2, logical, (:,:), 2, MPI_LOGICAL) + @:mpifx_gatherv_dr0_template(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) + @:mpifx_gatherv_dr0_template(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) + @:mpifx_gatherv_dr0_template(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) + @:mpifx_gatherv_dr0_template(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) + + @:mpifx_gatherv_dr1_template(i0i1, integer, , 1, (:), 1, MPI_INTEGER) + @:mpifx_gatherv_dr1_template(s0s1, real(sp), , 1, (:), 1, MPI_REAL) + @:mpifx_gatherv_dr1_template(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) + @:mpifx_gatherv_dr1_template(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) + @:mpifx_gatherv_dr1_template(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) + @:mpifx_gatherv_dr1_template(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + +end module mpifx_gatherv_module diff --git a/lib/mpifx_helper.fpp b/lib/mpifx_helper.fpp index 61b84e0..bc41185 100644 --- a/lib/mpifx_helper.fpp +++ b/lib/mpifx_helper.fpp @@ -5,13 +5,13 @@ !! \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 From 29ca4059521f66c9dfa498218aa2a8f17121590b Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Tue, 27 Aug 2019 18:34:08 +0200 Subject: [PATCH 54/72] Fix mpifx_helper.fpp --- lib/mpifx_helper.fpp | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/mpifx_helper.fpp b/lib/mpifx_helper.fpp index bc41185..70fa09b 100644 --- a/lib/mpifx_helper.fpp +++ b/lib/mpifx_helper.fpp @@ -12,6 +12,7 @@ module mpifx_helper_module public :: default_tag, sp, dp public :: handle_errorflag, assert_failed + public :: getoptarg, setoptarg !> Default tag integer, parameter :: default_tag = 0 From c6760e50a9a0edc750e1adee9df8fd929152a812 Mon Sep 17 00:00:00 2001 From: Kristoffer Rehling Date: Fri, 30 Aug 2019 11:14:44 +0200 Subject: [PATCH 55/72] Remove old m4 and F90 files --- src/Makefile.dep | 132 ------------------------------- src/mpifx_allgatherv.F90 | 163 -------------------------------------- src/mpifx_allgatherv.m4 | 108 ------------------------- src/mpifx_gatherv.F90 | 167 --------------------------------------- src/mpifx_gatherv.m4 | 138 -------------------------------- 5 files changed, 708 deletions(-) delete mode 100644 src/Makefile.dep delete mode 100644 src/mpifx_allgatherv.F90 delete mode 100644 src/mpifx_allgatherv.m4 delete mode 100644 src/mpifx_gatherv.F90 delete mode 100644 src/mpifx_gatherv.m4 diff --git a/src/Makefile.dep b/src/Makefile.dep deleted file mode 100644 index 6e9889e..0000000 --- a/src/Makefile.dep +++ /dev/null @@ -1,132 +0,0 @@ -.SECONDEXPANSION: - -mpifx_barrier.o: mpifx_barrier.m4 $$(_modobj_mpifx_common_module) -mpifx_barrier.o = mpifx_barrier.o $(mpifx_barrier.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_barrier_module = mpifx_barrier.o - -mpifx_init.m4: mpifx_common.m4 -mpifx_init.m4 = $(mpifx_common.m4) - -mpifx_abort.o: mpifx_abort.m4 $$(_modobj_mpifx_common_module) -mpifx_abort.o = mpifx_abort.o $(mpifx_abort.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_abort_module = mpifx_abort.o - -mpifx_constants.o: mpifx_constants.m4 $$(_modobj_mpi) -mpifx_constants.o = mpifx_constants.o $(mpifx_constants.m4) $($(_modobj_mpi)) -_modobj_mpifx_constants_module = mpifx_constants.o - -mpifx_allreduce.o: mpifx_allreduce.m4 $$(_modobj_mpifx_common_module) -mpifx_allreduce.o = mpifx_allreduce.o $(mpifx_allreduce.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allreduce_module = mpifx_allreduce.o - -mpifx_send.o: mpifx_send.m4 $$(_modobj_mpifx_common_module) -mpifx_send.o = mpifx_send.o $(mpifx_send.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_send_module = mpifx_send.o - -mpifx_get_processor_name.m4: mpifx_helper.m4 -mpifx_get_processor_name.m4 = $(mpifx_helper.m4) - -mpifx_reduce.m4: mpifx_common.m4 -mpifx_reduce.m4 = $(mpifx_common.m4) - -mpifx_gather.o: $$(_modobj_mpifx_common_module) mpifx_gather.m4 -mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) $(mpifx_gather.m4) -_modobj_mpifx_gather_module = mpifx_gather.o - -mpifx_gatherv.o: $$(_modobj_mpifx_common_module) mpifx_gatherv.m4 -mpifx_gatherv.o = mpifx_gatherv.o $($(_modobj_mpifx_common_module)) $(mpifx_gatherv.m4) -_modobj_mpifx_gatherv_module = mpifx_gatherv.o - -mpifx_comm.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_comm.m4 -mpifx_comm.o = mpifx_comm.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_comm.m4) -_modobj_mpifx_comm_module = mpifx_comm.o - -mpifx_scatter.o: $$(_modobj_mpifx_common_module) mpifx_scatter.m4 -mpifx_scatter.o = mpifx_scatter.o $($(_modobj_mpifx_common_module)) $(mpifx_scatter.m4) -_modobj_mpifx_scatter_module = mpifx_scatter.o - -mpifx_scatter.m4: mpifx_common.m4 -mpifx_scatter.m4 = $(mpifx_common.m4) - -mpifx_finalize.o: mpifx_finalize.m4 $$(_modobj_mpifx_common_module) -mpifx_finalize.o = mpifx_finalize.o $(mpifx_finalize.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_finalize_module = mpifx_finalize.o - -mpifx_barrier.m4: mpifx_common.m4 -mpifx_barrier.m4 = $(mpifx_common.m4) - -mpifx_recv.m4: mpifx_common.m4 -mpifx_recv.m4 = $(mpifx_common.m4) - -mpifx_helper.o: mpifx_helper.m4 $$(_modobj_mpi) $$(_modobj_mpifx_constants_module) -mpifx_helper.o = mpifx_helper.o $(mpifx_helper.m4) $($(_modobj_mpi)) $($(_modobj_mpifx_constants_module)) -_modobj_mpifx_helper_module = mpifx_helper.o - -mpifx_gather.m4: mpifx_common.m4 -mpifx_gather.m4 = $(mpifx_common.m4) - -mpifx_gatherv.m4: mpifx_common.m4 -mpifx_gatherv.m4 = $(mpifx_common.m4) - -mpifx_finalize.m4: mpifx_common.m4 -mpifx_finalize.m4 = $(mpifx_common.m4) - -mpifx_get_processor_name.o: $$(_modobj_mpi) $$(_modobj_mpifx_helper_module) mpifx_get_processor_name.m4 -mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpi)) $($(_modobj_mpifx_helper_module)) $(mpifx_get_processor_name.m4) -_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o - -mpifx_allgather.o: mpifx_allgather.m4 $$(_modobj_mpifx_common_module) -mpifx_allgather.o = mpifx_allgather.o $(mpifx_allgather.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allgather_module = mpifx_allgather.o - -mpifx_allgatherv.o: mpifx_allgatherv.m4 $$(_modobj_mpifx_common_module) -mpifx_allgatherv.o = mpifx_allgatherv.o $(mpifx_allgatherv.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allgatherv_module = mpifx_allgatherv.o - -mpifx_init.o: mpifx_init.m4 $$(_modobj_mpifx_common_module) $$(_modobj_mpifx_constants_module) -mpifx_init.o = mpifx_init.o $(mpifx_init.m4) $($(_modobj_mpifx_common_module)) $($(_modobj_mpifx_constants_module)) -_modobj_mpifx_init_module = mpifx_init.o - -mpifx_abort.m4: mpifx_common.m4 -mpifx_abort.m4 = $(mpifx_common.m4) - -mpifx_bcast.o: $$(_modobj_mpifx_common_module) mpifx_bcast.m4 -mpifx_bcast.o = mpifx_bcast.o $($(_modobj_mpifx_common_module)) $(mpifx_bcast.m4) -_modobj_mpifx_bcast_module = mpifx_bcast.o - -mpifx_send.m4: mpifx_common.m4 -mpifx_send.m4 = $(mpifx_common.m4) - -mpifx_common.o: $$(_modobj_mpi) mpifx_common.m4 $$(_modobj_mpifx_comm_module) $$(_modobj_mpifx_helper_module) -mpifx_common.o = mpifx_common.o $($(_modobj_mpi)) $(mpifx_common.m4) $($(_modobj_mpifx_comm_module)) $($(_modobj_mpifx_helper_module)) -_modobj_mpifx_common_module = mpifx_common.o - -mpifx_common.m4: mpifx_helper.m4 -mpifx_common.m4 = $(mpifx_helper.m4) - -mpifx_bcast.m4: mpifx_common.m4 -mpifx_bcast.m4 = $(mpifx_common.m4) - -libmpifx.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_allgatherv_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -libmpifx.o = libmpifx.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_allgatherv_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) -_modobj_libmpifx_module = libmpifx.o - -mpifx_allreduce.m4: mpifx_common.m4 -mpifx_allreduce.m4 = $(mpifx_common.m4) - -mpifx_reduce.o: mpifx_reduce.m4 $$(_modobj_mpifx_common_module) -mpifx_reduce.o = mpifx_reduce.o $(mpifx_reduce.m4) $($(_modobj_mpifx_common_module)) -_modobj_mpifx_reduce_module = mpifx_reduce.o - -mpifx_recv.o: $$(_modobj_mpifx_common_module) mpifx_recv.m4 -mpifx_recv.o = mpifx_recv.o $($(_modobj_mpifx_common_module)) $(mpifx_recv.m4) -_modobj_mpifx_recv_module = mpifx_recv.o - -mpifx_comm.m4: mpifx_helper.m4 -mpifx_comm.m4 = $(mpifx_helper.m4) - -mpifx_allgather.m4: mpifx_common.m4 -mpifx_allgather.m4 = $(mpifx_common.m4) - -mpifx_allgatherv.m4: mpifx_common.m4 -mpifx_allgatherv.m4 = $(mpifx_common.m4) diff --git a/src/mpifx_allgatherv.F90 b/src/mpifx_allgatherv.F90 deleted file mode 100644 index ad3b087..0000000 --- a/src/mpifx_allgatherv.F90 +++ /dev/null @@ -1,163 +0,0 @@ -include(mpifx_allgatherv.m4) - -!> 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%master) then - !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 - !! end if - !! - !! call mpifx_finalize() - !! - !! end program test_allgatherv - !! - interface mpifx_allgatherv - module procedure & - & mpifx_allgatherv_i1i1, mpifx_allgatherv_i2i2, mpifx_allgatherv_i3i3, & - & mpifx_allgatherv_i4i4, mpifx_allgatherv_i5i5, mpifx_allgatherv_i6i6 - module procedure & - & mpifx_allgatherv_i0i1 - module procedure & - & mpifx_allgatherv_s1s1, mpifx_allgatherv_s2s2, mpifx_allgatherv_s3s3, & - & mpifx_allgatherv_s4s4, mpifx_allgatherv_s5s5, mpifx_allgatherv_s6s6 - module procedure & - & mpifx_allgatherv_s0s1 - module procedure & - & mpifx_allgatherv_d1d1, mpifx_allgatherv_d2d2, mpifx_allgatherv_d3d3, & - & mpifx_allgatherv_d4d4, mpifx_allgatherv_d5d5, mpifx_allgatherv_d6d6 - module procedure & - & mpifx_allgatherv_d0d1 - module procedure & - & mpifx_allgatherv_c1c1, mpifx_allgatherv_c2c2, mpifx_allgatherv_c3c3, & - & mpifx_allgatherv_c4c4, mpifx_allgatherv_c5c5, mpifx_allgatherv_c6c6 - module procedure & - & mpifx_allgatherv_c0c1 - module procedure & - & mpifx_allgatherv_z1z1, mpifx_allgatherv_z2z2, mpifx_allgatherv_z3z3, & - & mpifx_allgatherv_z4z4, mpifx_allgatherv_z5z5, mpifx_allgatherv_z6z6 - module procedure & - & mpifx_allgatherv_z0z1 - module procedure & - & mpifx_allgatherv_l1l1, mpifx_allgatherv_l2l2, mpifx_allgatherv_l3l3, & - & mpifx_allgatherv_l4l4, mpifx_allgatherv_l5l5, mpifx_allgatherv_l6l6 - module procedure & - & mpifx_allgatherv_l0l1 - end interface mpifx_allgatherv - - -contains - - _subroutine_mpifx_allgatherv_dr0(i1i1, integer, (:), 1, MPI_INTEGER) - _subroutine_mpifx_allgatherv_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) - _subroutine_mpifx_allgatherv_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - _subroutine_mpifx_allgatherv_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - _subroutine_mpifx_allgatherv_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_allgatherv_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - - _subroutine_mpifx_allgatherv_dr0(s1s1, real(sp), (:), 1, MPI_REAL) - _subroutine_mpifx_allgatherv_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) - _subroutine_mpifx_allgatherv_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - _subroutine_mpifx_allgatherv_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - _subroutine_mpifx_allgatherv_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_allgatherv_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - - _subroutine_mpifx_allgatherv_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgatherv_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgatherv_dr0(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgatherv_dr0(d4d4, real(dp), (:,:,:,:), 4, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgatherv_dr0(d5d5, real(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgatherv_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_PRECISION) - - - _subroutine_mpifx_allgatherv_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - _subroutine_mpifx_allgatherv_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(z3z3, complex(dp), (:,:,:), 3, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(z4z4, complex(dp), (:,:,:,:), 4, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgatherv_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_COMPLEX) - - - _subroutine_mpifx_allgatherv_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_allgatherv_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) - _subroutine_mpifx_allgatherv_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - _subroutine_mpifx_allgatherv_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - _subroutine_mpifx_allgatherv_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_allgatherv_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - _subroutine_mpifx_allgatherv_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) - _subroutine_mpifx_allgatherv_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) - _subroutine_mpifx_allgatherv_dr1(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_allgatherv_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) - _subroutine_mpifx_allgatherv_dr1(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_allgatherv_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) - -end module mpifx_allgatherv_module diff --git a/src/mpifx_allgatherv.m4 b/src/mpifx_allgatherv.m4 deleted file mode 100644 index aca8ecf..0000000 --- a/src/mpifx_allgatherv.m4 +++ /dev/null @@ -1,108 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_allgatherv -dnl ************************************************************************ - -define(`_subroutine_mpifx_allgatherv_dr0',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send/recv buffer rank (1, 2, etc.) -dnl $5: corresponding MPI type -dnl -!> Gathers results of variable length on all processes (type $1). -!! -!! \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_$1(mycomm, send, recv, recvcounts, displs, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$3 - 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), $5, recv, recvcounts, displs0, & - & $5, mycomm%id, error0) - - call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_$1", error) - -end subroutine mpifx_allgatherv_$1 -') - - -define(`_subroutine_mpifx_allgatherv_dr1',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send buffer size (1 or size(send)) -dnl $5: recv buffer rank specifier ((:), (:,:), etc.) -dnl $6: recv buffers rank (1, 2, etc.) -dnl $7: corresponding MPI type -dnl -!> Gathers results on one process (type $1). -!! -!! \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_$1(mycomm, send, recv, recvcounts, displs, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$5 - 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=$6) == 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, $4, $7, recv, recvcounts, displs0, & - & $7, mycomm%id, error0) - - call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_$1", error) - -end subroutine mpifx_allgatherv_$1 -') diff --git a/src/mpifx_gatherv.F90 b/src/mpifx_gatherv.F90 deleted file mode 100644 index 76e7834..0000000 --- a/src/mpifx_gatherv.F90 +++ /dev/null @@ -1,167 +0,0 @@ -include(mpifx_gatherv.m4) - -!> 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%master) 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%master) then - !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 - !! end if - !! - !! call mpifx_finalize() - !! - !! end program test_gatherv - !! - interface mpifx_gatherv - module procedure & - & mpifx_gatherv_i1i1, mpifx_gatherv_i2i2, mpifx_gatherv_i3i3, & - & mpifx_gatherv_i4i4, mpifx_gatherv_i5i5, mpifx_gatherv_i6i6 - module procedure & - & mpifx_gatherv_i0i1 - module procedure & - & mpifx_gatherv_s1s1, mpifx_gatherv_s2s2, mpifx_gatherv_s3s3, & - & mpifx_gatherv_s4s4, mpifx_gatherv_s5s5, mpifx_gatherv_s6s6 - module procedure & - & mpifx_gatherv_s0s1 - module procedure & - & mpifx_gatherv_d1d1, mpifx_gatherv_d2d2, mpifx_gatherv_d3d3, & - & mpifx_gatherv_d4d4, mpifx_gatherv_d5d5, mpifx_gatherv_d6d6 - module procedure & - & mpifx_gatherv_d0d1 - module procedure & - & mpifx_gatherv_c1c1, mpifx_gatherv_c2c2, mpifx_gatherv_c3c3, & - & mpifx_gatherv_c4c4, mpifx_gatherv_c5c5, mpifx_gatherv_c6c6 - module procedure & - & mpifx_gatherv_c0c1 - module procedure & - & mpifx_gatherv_z1z1, mpifx_gatherv_z2z2, mpifx_gatherv_z3z3, & - & mpifx_gatherv_z4z4, mpifx_gatherv_z5z5, mpifx_gatherv_z6z6 - module procedure & - & mpifx_gatherv_z0z1 - module procedure & - & mpifx_gatherv_l1l1, mpifx_gatherv_l2l2, mpifx_gatherv_l3l3, & - & mpifx_gatherv_l4l4, mpifx_gatherv_l5l5, mpifx_gatherv_l6l6 - module procedure & - & mpifx_gatherv_l0l1 - end interface mpifx_gatherv - - -contains - - _subroutine_mpifx_gatherv_dr0(i1i1, integer, (:), 1, MPI_INTEGER) - _subroutine_mpifx_gatherv_dr0(i2i2, integer, (:,:), 2, MPI_INTEGER) - _subroutine_mpifx_gatherv_dr0(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - _subroutine_mpifx_gatherv_dr0(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - _subroutine_mpifx_gatherv_dr0(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - _subroutine_mpifx_gatherv_dr0(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - - _subroutine_mpifx_gatherv_dr0(s1s1, real(sp), (:), 1, MPI_REAL) - _subroutine_mpifx_gatherv_dr0(s2s2, real(sp), (:,:), 2, MPI_REAL) - _subroutine_mpifx_gatherv_dr0(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - _subroutine_mpifx_gatherv_dr0(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - _subroutine_mpifx_gatherv_dr0(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - _subroutine_mpifx_gatherv_dr0(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - - _subroutine_mpifx_gatherv_dr0(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gatherv_dr0(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gatherv_dr0(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gatherv_dr0(d4d4, real(dp), (:,:,:,:), 4, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gatherv_dr0(d5d5, real(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gatherv_dr0(d6d6, real(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_PRECISION) - - - _subroutine_mpifx_gatherv_dr0(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - _subroutine_mpifx_gatherv_dr0(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - _subroutine_mpifx_gatherv_dr0(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - _subroutine_mpifx_gatherv_dr0(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - _subroutine_mpifx_gatherv_dr0(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) - _subroutine_mpifx_gatherv_dr0(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - _subroutine_mpifx_gatherv_dr0(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gatherv_dr0(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gatherv_dr0(z3z3, complex(dp), (:,:,:), 3, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gatherv_dr0(z4z4, complex(dp), (:,:,:,:), 4, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gatherv_dr0(z5z5, complex(dp), (:,:,:,:,:), 5, - MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gatherv_dr0(z6z6, complex(dp), (:,:,:,:,:,:), 6, - MPI_DOUBLE_COMPLEX) - - - _subroutine_mpifx_gatherv_dr0(l1l1, logical, (:), 1, MPI_LOGICAL) - _subroutine_mpifx_gatherv_dr0(l2l2, logical, (:,:), 2, MPI_LOGICAL) - _subroutine_mpifx_gatherv_dr0(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - _subroutine_mpifx_gatherv_dr0(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - _subroutine_mpifx_gatherv_dr0(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - _subroutine_mpifx_gatherv_dr0(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - _subroutine_mpifx_gatherv_dr1(i0i1, integer, , 1, (:), 1, MPI_INTEGER) - _subroutine_mpifx_gatherv_dr1(s0s1, real(sp), , 1, (:), 1, MPI_REAL) - _subroutine_mpifx_gatherv_dr1(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) - _subroutine_mpifx_gatherv_dr1(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) - _subroutine_mpifx_gatherv_dr1(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) - _subroutine_mpifx_gatherv_dr1(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) - -end module mpifx_gatherv_module diff --git a/src/mpifx_gatherv.m4 b/src/mpifx_gatherv.m4 deleted file mode 100644 index 3d43850..0000000 --- a/src/mpifx_gatherv.m4 +++ /dev/null @@ -1,138 +0,0 @@ -include(mpifx_common.m4) - -dnl ************************************************************************ -dnl *** mpifx_gatherv -dnl ************************************************************************ - -define(`_subroutine_mpifx_gatherv_dr0',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send/recv buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send/recv buffer rank (1, 2, etc.) -dnl $5: corresponding MPI type -dnl -!> Gathers results of variable length on one process (type $1). -!! -!! \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%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$3 - 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(:) - - _handle_inoptflag(root0, root, mycomm%masterrank) - - 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), $5, recv, recvcounts, displs0, & - & $5, root0, mycomm%id, error0) - - call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error) - -end subroutine mpifx_gatherv_$1 -') - - -define(`_subroutine_mpifx_gatherv_dr1',`dnl -dnl -dnl $1: subroutine suffix -dnl $2: send/recv buffer type -dnl $3: send buffer rank specifier ("", (:), (:,:), etc.) -dnl $4: send buffer size (1 or size(send)) -dnl $5: recv buffer rank specifier ((:), (:,:), etc.) -dnl $6: recv buffers rank (1, 2, etc.) -dnl $7: corresponding MPI type -dnl -!> Gathers results on one process (type $1). -!! -!! \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%masterrank) -!! \param error Error code on exit. -!! -subroutine mpifx_gatherv_$1(mycomm, send, recv, recvcounts, displs, root, error) - type(mpifx_comm), intent(in) :: mycomm - $2, intent(in) :: send$3 - $2, intent(out) :: recv$5 - 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(:) - - _handle_inoptflag(root0, root, mycomm%masterrank) - - if (mycomm%rank == root0) then - _assert(size(recv) == sum(recvcounts)) - _assert(size(recv, dim=$6) == 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, $4, $7, recv, recvcounts, displs0, & - & $7, root0, mycomm%id, error0) - - call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_$1", error) - -end subroutine mpifx_gatherv_$1 -') - From a23148101a773bdf67150e2e3b3e8e1f9b12d543 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 2 Sep 2019 13:48:55 +0200 Subject: [PATCH 56/72] Fix merge issues --- CMakeLists.txt | 8 +++++++- lib/CMakeLists.txt | 44 ++++++++++++++++++++++---------------------- 2 files changed, 29 insertions(+), 23 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index dacab1c..f5c9678 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -22,8 +22,14 @@ option(BUILD_SHARED_LIBS "Whether the library should be shared" FALSE) option(INSTALL_INCLUDE_FILES "Whether include and module files should be installed" TRUE) find_package(MPI REQUIRED) +find_program(FYPP fypp) +if(FYPP) + message(STATUS "Preprocessor fypp: ${FYPP}") +else() + message(FATAL_ERROR "Prepropcessor fypp not found") +endif() -add_subdirectory(src) +add_subdirectory(lib) if(NOT LIBRARY_ONLY) add_subdirectory(test) endif() diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index 3e6ea7d..c884ad1 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -1,32 +1,32 @@ set(sources-fpp - libmpifx.F90 - mpifx_abort.F90 - mpifx_allgather.F90 - mpifx_allgatherv.F90 - mpifx_allreduce.F90 - mpifx_barrier.F90 - mpifx_bcast.F90 - mpifx_comm.F90 - mpifx_common.F90 - mpifx_constants.F90 - mpifx_finalize.F90 - mpifx_gather.F90 - mpifx_gatherv.F90 - mpifx_get_processor_name.F90 - mpifx_helper.F90 - mpifx_init.F90 - mpifx_recv.F90 - mpifx_reduce.F90 - mpifx_scatter.F90 - mpifx_send.F90) + 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_send.fpp) set(sources-f90-preproc) foreach(fppsrc IN LISTS sources-fpp) - string(REGEX REPLACE "\\.F90" ".f90" f90src ${fppsrc}) + string(REGEX REPLACE "\\.fpp" ".f90" f90src ${fppsrc}) add_custom_command( OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${f90src} - COMMAND m4 -I${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc} > ${CMAKE_CURRENT_BINARY_DIR}/${f90src} + COMMAND ${FYPP} -I${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc} ${CMAKE_CURRENT_BINARY_DIR}/${f90src} MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc}) list(APPEND sources-f90-preproc ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) endforeach() From a9903011f02d30cc230b60abf8807189e27d04f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Mon, 2 Sep 2019 15:12:47 +0200 Subject: [PATCH 57/72] Make minor stylistic changes --- lib/module.fpp | 11 --- lib/mpifx_allgatherv.fpp | 163 +++++++++++--------------------------- lib/mpifx_gatherv.fpp | 164 ++++++++++----------------------------- 3 files changed, 88 insertions(+), 250 deletions(-) diff --git a/lib/module.fpp b/lib/module.fpp index 72e644c..bdf5def 100644 --- a/lib/module.fpp +++ b/lib/module.fpp @@ -1,25 +1,14 @@ !> \mainpage Modern Fortran wrappers around MPI routines !! -!!<<<<<<< HEAD:lib/module.fpp -!! The open source library [MPIFX](https://www.bitbucket.org/dftbplus/mpifx) is -!!======= !! The open source library [MPIFX](https://github.com/dftbplus/mpifx) is -!!>>>>>>> master:src/libmpifx.F90 !! 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: -!!<<<<<<< HEAD:lib/module.fpp -!! * [Online documentation](https://dftbplus.bitbucket.org/mpifx/) -!! for installation and usage of the library -!! * [API documentation](annotated.html) for the reference manual. -!! * [Project home page](https://www.bitbucket.org/dftbplus/mpifx/) -!!======= !! * [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) -!!>>>>>>> master:src/libmpifx.F90 !! for the source code, bug tracker and further information on the project. !! module libmpifx_module diff --git a/lib/mpifx_allgatherv.fpp b/lib/mpifx_allgatherv.fpp index 2759dfa..b64fe4c 100644 --- a/lib/mpifx_allgatherv.fpp +++ b/lib/mpifx_allgatherv.fpp @@ -1,5 +1,6 @@ #:include 'mpifx.fypp' #:set TYPES = ALL_TYPES +#:set RANKS = range(1, MAX_RANK + 1) #! ************************************************************************ @@ -7,16 +8,9 @@ #! ************************************************************************ -#:def mpifx_allgatherv_dr0_template(VAR1, VAR2, VAR3, VAR4, VAR5) -#! - #! - #! ${VAR1}$: subroutine suffix - #! ${VAR2}$: send/recv buffer type - #! ${VAR3}$: send/recv buffer rank specifier ("", (:), (:,:), etc.) - #! ${VAR4}$: send/recv buffer rank (1, 2, etc.) - #! ${VAR5}$: corresponding MPI type - #! - !> Gathers results of variable length on all processes (type ${VAR1}$). +#: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. @@ -26,10 +20,10 @@ !! (default: computed from recvcounts assuming order with rank) !! \param error Error code on exit. !! - subroutine mpifx_allgatherv_${VAR1}$(mycomm, send, recv, recvcounts, displs, error) + subroutine mpifx_allgatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, error) type(mpifx_comm), intent(in) :: mycomm - ${VAR2}$, intent(in) :: send${VAR3}$ - ${VAR2}$, intent(out) :: recv${VAR3}$ + ${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 @@ -50,29 +44,24 @@ end do end if - call mpi_allgatherv(send, size(send), ${VAR5}$, recv, recvcounts, displs0, & - & ${VAR5}$, mycomm%id, error0) + 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_${VAR1}$", error) + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_${SUFFIX}$", error) - end subroutine mpifx_allgatherv_${VAR1}$ + end subroutine mpifx_allgatherv_${SUFFIX}$ #:enddef -#:def mpifx_allgatherv_dr1_template(VAR1, VAR2, VAR3, VAR4, VAR5, VAR6, VAR7) -#! +#:def mpifx_allgatherv_dr1_template(SUFFIX, TYPE, SEND_RANK, SEND_BUFFER_SIZE, RECV_RANK, MPI_TYPE) + #! #! - #! ${VAR1}$: subroutine suffix - #! ${VAR2}$: send/recv buffer type - #! ${VAR3}$: send buffer rank specifier ("", (:), (:,:), etc.) - #! ${VAR4}$: send buffer size (1 or size(send)) - #! ${VAR5}$: recv buffer rank specifier ((:), (:,:), etc.) - #! ${VAR6}$: recv buffers rank (1, 2, etc.) - #! ${VAR7}$: corresponding MPI type + #! ${BUFFER_SIZE}$: send buffer size (1 or size(send)) + #! ${MPI_TYPE}$: corresponding MPI type #! - !> Gathers results on one process (type ${VAR1}$). + !> Gathers results on one process (type ${SUFFIX}$). !! !! \param mycomm MPI communicator. !! \param send Quantity to be sent for gathering. @@ -82,10 +71,10 @@ !! (default: computed from recvcounts assuming order with rank) !! \param error Error code on exit. !! - subroutine mpifx_allgatherv_${VAR1}$(mycomm, send, recv, recvcounts, displs, error) + subroutine mpifx_allgatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, error) type(mpifx_comm), intent(in) :: mycomm - ${VAR2}$, intent(in) :: send${VAR3}$ - ${VAR2}$, intent(out) :: recv${VAR5}$ + ${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 @@ -94,7 +83,7 @@ integer, allocatable :: displs0(:) @:ASSERT(size(recv) == sum(recvcounts)) - @:ASSERT(size(recv, dim=${VAR6}$) == mycomm%size) + @:ASSERT(size(recv, dim=${RECV_RANK}$) == mycomm%size) allocate(displs0(mycomm%size)) if (present(displs)) then @:ASSERT(size(displs) == mycomm%size) @@ -106,12 +95,12 @@ end do end if - call mpi_allgatherv(send, ${VAR4}$, ${VAR7}$, recv, recvcounts, displs0, & - & ${VAR7}$, mycomm%id, error0) + 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_${VAR1}$", error) + call handle_errorflag(error0, "MPI_ALLGATHERV in mpifx_allgatherv_${SUFFIX}$", error) - end subroutine mpifx_allgatherv_${VAR1}$ + end subroutine mpifx_allgatherv_${SUFFIX}$ #:enddef @@ -179,93 +168,31 @@ module mpifx_allgatherv_module !! end program test_allgatherv !! interface mpifx_allgatherv - module procedure & - & mpifx_allgatherv_i1i1, mpifx_allgatherv_i2i2, mpifx_allgatherv_i3i3, & - & mpifx_allgatherv_i4i4, mpifx_allgatherv_i5i5, mpifx_allgatherv_i6i6 - module procedure & - & mpifx_allgatherv_i0i1 - module procedure & - & mpifx_allgatherv_s1s1, mpifx_allgatherv_s2s2, mpifx_allgatherv_s3s3, & - & mpifx_allgatherv_s4s4, mpifx_allgatherv_s5s5, mpifx_allgatherv_s6s6 - module procedure & - & mpifx_allgatherv_s0s1 - module procedure & - & mpifx_allgatherv_d1d1, mpifx_allgatherv_d2d2, mpifx_allgatherv_d3d3, & - & mpifx_allgatherv_d4d4, mpifx_allgatherv_d5d5, mpifx_allgatherv_d6d6 - module procedure & - & mpifx_allgatherv_d0d1 - module procedure & - & mpifx_allgatherv_c1c1, mpifx_allgatherv_c2c2, mpifx_allgatherv_c3c3, & - & mpifx_allgatherv_c4c4, mpifx_allgatherv_c5c5, mpifx_allgatherv_c6c6 - module procedure & - & mpifx_allgatherv_c0c1 - module procedure & - & mpifx_allgatherv_z1z1, mpifx_allgatherv_z2z2, mpifx_allgatherv_z3z3, & - & mpifx_allgatherv_z4z4, mpifx_allgatherv_z5z5, mpifx_allgatherv_z6z6 - module procedure & - & mpifx_allgatherv_z0z1 - module procedure & - & mpifx_allgatherv_l1l1, mpifx_allgatherv_l2l2, mpifx_allgatherv_l3l3, & - & mpifx_allgatherv_l4l4, mpifx_allgatherv_l5l5, mpifx_allgatherv_l6l6 - module procedure & - & mpifx_allgatherv_l0l1 + #: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 - @:mpifx_allgatherv_dr0_template(i1i1, integer, (:), 1, MPI_INTEGER) - @:mpifx_allgatherv_dr0_template(i2i2, integer, (:,:), 2, MPI_INTEGER) - @:mpifx_allgatherv_dr0_template(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - @:mpifx_allgatherv_dr0_template(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - @:mpifx_allgatherv_dr0_template(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - @:mpifx_allgatherv_dr0_template(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - - @:mpifx_allgatherv_dr0_template(s1s1, real(sp), (:), 1, MPI_REAL) - @:mpifx_allgatherv_dr0_template(s2s2, real(sp), (:,:), 2, MPI_REAL) - @:mpifx_allgatherv_dr0_template(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - @:mpifx_allgatherv_dr0_template(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - @:mpifx_allgatherv_dr0_template(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - @:mpifx_allgatherv_dr0_template(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - - @:mpifx_allgatherv_dr0_template(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - @:mpifx_allgatherv_dr0_template(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) - @:mpifx_allgatherv_dr0_template(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) - @:mpifx_allgatherv_dr0_template(d4d4, real(dp), (:,:,:,:), 4, MPI_DOUBLE_PRECISION) - @:mpifx_allgatherv_dr0_template(d5d5, real(dp), (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) - @:mpifx_allgatherv_dr0_template(d6d6, real(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) - - - @:mpifx_allgatherv_dr0_template(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - @:mpifx_allgatherv_dr0_template(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - @:mpifx_allgatherv_dr0_template(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - @:mpifx_allgatherv_dr0_template(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - @:mpifx_allgatherv_dr0_template(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) - @:mpifx_allgatherv_dr0_template(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - @:mpifx_allgatherv_dr0_template(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - @:mpifx_allgatherv_dr0_template(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) - @:mpifx_allgatherv_dr0_template(z3z3, complex(dp), (:,:,:), 3, MPI_DOUBLE_COMPLEX) - @:mpifx_allgatherv_dr0_template(z4z4, complex(dp), (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) - @:mpifx_allgatherv_dr0_template(z5z5, complex(dp), (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) - @:mpifx_allgatherv_dr0_template(z6z6, complex(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) - - - @:mpifx_allgatherv_dr0_template(l1l1, logical, (:), 1, MPI_LOGICAL) - @:mpifx_allgatherv_dr0_template(l2l2, logical, (:,:), 2, MPI_LOGICAL) - @:mpifx_allgatherv_dr0_template(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - @:mpifx_allgatherv_dr0_template(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - @:mpifx_allgatherv_dr0_template(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - @:mpifx_allgatherv_dr0_template(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - @:mpifx_allgatherv_dr1_template(i0i1, integer, , 1, (:), 1, MPI_INTEGER) - @:mpifx_allgatherv_dr1_template(s0s1, real(sp), , 1, (:), 1, MPI_REAL) - @:mpifx_allgatherv_dr1_template(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) - @:mpifx_allgatherv_dr1_template(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) - @:mpifx_allgatherv_dr1_template(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) - @:mpifx_allgatherv_dr1_template(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + #: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_gatherv.fpp b/lib/mpifx_gatherv.fpp index c4005a7..9cd8378 100644 --- a/lib/mpifx_gatherv.fpp +++ b/lib/mpifx_gatherv.fpp @@ -1,22 +1,15 @@ #:include 'mpifx.fypp' #:set TYPES = ALL_TYPES - +#:set RANKS = range(1, MAX_RANK + 1) #! ************************************************************************ #! *** mpifx_gatherv #! ************************************************************************ -#:def mpifx_gatherv_dr0_template(VAR1, VAR2, VAR3, VAR4, VAR5) -#! - #! - #! ${VAR1}$: subroutine suffix - #! ${VAR2}$: send/recv buffer type - #! ${VAR3}$: send/recv buffer rank specifier ("", (:), (:,:), etc.) - #! ${VAR4}$: send/recv buffer rank (1, 2, etc.) - #! ${VAR5}$: corresponding MPI type - #! - !> Gathers results of variable length on one process (type ${VAR1}$). +#: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. @@ -27,10 +20,10 @@ !! \param root Root process for the result (default: mycomm%masterrank) !! \param error Error code on exit. !! - subroutine mpifx_gatherv_${VAR1}$(mycomm, send, recv, recvcounts, displs, root, error) + subroutine mpifx_gatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, root, error) type(mpifx_comm), intent(in) :: mycomm - ${VAR2}$, intent(in) :: send${VAR3}$ - ${VAR2}$, intent(out) :: recv${VAR3}$ + ${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 @@ -73,29 +66,20 @@ end if end if - call mpi_gatherv(send, size(send), ${VAR5}$, recv, recvcounts, displs0, & - & ${VAR5}$, root0, mycomm%id, error0) + 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_${VAR1}$", error) + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_${SUFFIX}$", error) - end subroutine mpifx_gatherv_${VAR1}$ + end subroutine mpifx_gatherv_${SUFFIX}$ #:enddef -#:def mpifx_gatherv_dr1_template(VAR1, VAR2, VAR3, VAR4, VAR5, VAR6, VAR7) -#! - #! - #! ${VAR1}$: subroutine suffix - #! ${VAR2}$: send/recv buffer type - #! ${VAR3}$: send buffer rank specifier ("", (:), (:,:), etc.) - #! ${VAR4}$: send buffer size (1 or size(send)) - #! ${VAR5}$: recv buffer rank specifier ((:), (:,:), etc.) - #! ${VAR6}$: recv buffers rank (1, 2, etc.) - #! ${VAR7}$: corresponding MPI type - #! - !> Gathers results on one process (type ${VAR1}$). +#: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. @@ -106,10 +90,10 @@ !! \param root Root process for the result (default: mycomm%masterrank) !! \param error Error code on exit. !! - subroutine mpifx_gatherv_${VAR1}$(mycomm, send, recv, recvcounts, displs, root, error) + subroutine mpifx_gatherv_${SUFFIX}$(mycomm, send, recv, recvcounts, displs, root, error) type(mpifx_comm), intent(in) :: mycomm - ${VAR2}$, intent(in) :: send${VAR3}$ - ${VAR2}$, intent(out) :: recv${VAR5}$ + ${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 @@ -122,7 +106,7 @@ if (mycomm%rank == root0) then @:ASSERT(size(recv) == sum(recvcounts)) - @:ASSERT(size(recv, dim=${VAR6}$) == mycomm%size) + @:ASSERT(size(recv, dim=${RECV_RANK}$) == mycomm%size) allocate(displs0(mycomm%size)) if (present(displs)) then @:ASSERT(size(displs) == mycomm%size) @@ -135,12 +119,12 @@ end if end if - call mpi_gatherv(send, ${VAR4}$, ${VAR7}$, recv, recvcounts, displs0, & - & ${VAR7}$, root0, mycomm%id, error0) + 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_${VAR1}$", error) + call handle_errorflag(error0, "MPI_GATHERV in mpifx_gatherv_${SUFFIX}$", error) - end subroutine mpifx_gatherv_${VAR1}$ + end subroutine mpifx_gatherv_${SUFFIX}$ #:enddef @@ -213,93 +197,31 @@ module mpifx_gatherv_module !! end program test_gatherv !! interface mpifx_gatherv - module procedure & - & mpifx_gatherv_i1i1, mpifx_gatherv_i2i2, mpifx_gatherv_i3i3, & - & mpifx_gatherv_i4i4, mpifx_gatherv_i5i5, mpifx_gatherv_i6i6 - module procedure & - & mpifx_gatherv_i0i1 - module procedure & - & mpifx_gatherv_s1s1, mpifx_gatherv_s2s2, mpifx_gatherv_s3s3, & - & mpifx_gatherv_s4s4, mpifx_gatherv_s5s5, mpifx_gatherv_s6s6 - module procedure & - & mpifx_gatherv_s0s1 - module procedure & - & mpifx_gatherv_d1d1, mpifx_gatherv_d2d2, mpifx_gatherv_d3d3, & - & mpifx_gatherv_d4d4, mpifx_gatherv_d5d5, mpifx_gatherv_d6d6 - module procedure & - & mpifx_gatherv_d0d1 - module procedure & - & mpifx_gatherv_c1c1, mpifx_gatherv_c2c2, mpifx_gatherv_c3c3, & - & mpifx_gatherv_c4c4, mpifx_gatherv_c5c5, mpifx_gatherv_c6c6 - module procedure & - & mpifx_gatherv_c0c1 - module procedure & - & mpifx_gatherv_z1z1, mpifx_gatherv_z2z2, mpifx_gatherv_z3z3, & - & mpifx_gatherv_z4z4, mpifx_gatherv_z5z5, mpifx_gatherv_z6z6 - module procedure & - & mpifx_gatherv_z0z1 - module procedure & - & mpifx_gatherv_l1l1, mpifx_gatherv_l2l2, mpifx_gatherv_l3l3, & - & mpifx_gatherv_l4l4, mpifx_gatherv_l5l5, mpifx_gatherv_l6l6 - module procedure & - & mpifx_gatherv_l0l1 + #: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 - @:mpifx_gatherv_dr0_template(i1i1, integer, (:), 1, MPI_INTEGER) - @:mpifx_gatherv_dr0_template(i2i2, integer, (:,:), 2, MPI_INTEGER) - @:mpifx_gatherv_dr0_template(i3i3, integer, (:,:,:), 3, MPI_INTEGER) - @:mpifx_gatherv_dr0_template(i4i4, integer, (:,:,:,:), 4, MPI_INTEGER) - @:mpifx_gatherv_dr0_template(i5i5, integer, (:,:,:,:,:), 5, MPI_INTEGER) - @:mpifx_gatherv_dr0_template(i6i6, integer, (:,:,:,:,:,:), 6, MPI_INTEGER) - - - @:mpifx_gatherv_dr0_template(s1s1, real(sp), (:), 1, MPI_REAL) - @:mpifx_gatherv_dr0_template(s2s2, real(sp), (:,:), 2, MPI_REAL) - @:mpifx_gatherv_dr0_template(s3s3, real(sp), (:,:,:), 3, MPI_REAL) - @:mpifx_gatherv_dr0_template(s4s4, real(sp), (:,:,:,:), 4, MPI_REAL) - @:mpifx_gatherv_dr0_template(s5s5, real(sp), (:,:,:,:,:), 5, MPI_REAL) - @:mpifx_gatherv_dr0_template(s6s6, real(sp), (:,:,:,:,:,:), 6, MPI_REAL) - - - @:mpifx_gatherv_dr0_template(d1d1, real(dp), (:), 1, MPI_DOUBLE_PRECISION) - @:mpifx_gatherv_dr0_template(d2d2, real(dp), (:,:), 2, MPI_DOUBLE_PRECISION) - @:mpifx_gatherv_dr0_template(d3d3, real(dp), (:,:,:), 3, MPI_DOUBLE_PRECISION) - @:mpifx_gatherv_dr0_template(d4d4, real(dp), (:,:,:,:), 4, MPI_DOUBLE_PRECISION) - @:mpifx_gatherv_dr0_template(d5d5, real(dp), (:,:,:,:,:), 5, MPI_DOUBLE_PRECISION) - @:mpifx_gatherv_dr0_template(d6d6, real(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_PRECISION) - - - @:mpifx_gatherv_dr0_template(c1c1, complex(sp), (:), 1, MPI_COMPLEX) - @:mpifx_gatherv_dr0_template(c2c2, complex(sp), (:,:), 2, MPI_COMPLEX) - @:mpifx_gatherv_dr0_template(c3c3, complex(sp), (:,:,:), 3, MPI_COMPLEX) - @:mpifx_gatherv_dr0_template(c4c4, complex(sp), (:,:,:,:), 4, MPI_COMPLEX) - @:mpifx_gatherv_dr0_template(c5c5, complex(sp), (:,:,:,:,:), 5, MPI_COMPLEX) - @:mpifx_gatherv_dr0_template(c6c6, complex(sp), (:,:,:,:,:,:), 6, MPI_COMPLEX) - - - @:mpifx_gatherv_dr0_template(z1z1, complex(dp), (:), 1, MPI_DOUBLE_COMPLEX) - @:mpifx_gatherv_dr0_template(z2z2, complex(dp), (:,:), 2, MPI_DOUBLE_COMPLEX) - @:mpifx_gatherv_dr0_template(z3z3, complex(dp), (:,:,:), 3, MPI_DOUBLE_COMPLEX) - @:mpifx_gatherv_dr0_template(z4z4, complex(dp), (:,:,:,:), 4, MPI_DOUBLE_COMPLEX) - @:mpifx_gatherv_dr0_template(z5z5, complex(dp), (:,:,:,:,:), 5, MPI_DOUBLE_COMPLEX) - @:mpifx_gatherv_dr0_template(z6z6, complex(dp), (:,:,:,:,:,:), 6, MPI_DOUBLE_COMPLEX) - - - @:mpifx_gatherv_dr0_template(l1l1, logical, (:), 1, MPI_LOGICAL) - @:mpifx_gatherv_dr0_template(l2l2, logical, (:,:), 2, MPI_LOGICAL) - @:mpifx_gatherv_dr0_template(l3l3, logical, (:,:,:), 3, MPI_LOGICAL) - @:mpifx_gatherv_dr0_template(l4l4, logical, (:,:,:,:), 4, MPI_LOGICAL) - @:mpifx_gatherv_dr0_template(l5l5, logical, (:,:,:,:,:), 5, MPI_LOGICAL) - @:mpifx_gatherv_dr0_template(l6l6, logical, (:,:,:,:,:,:), 6, MPI_LOGICAL) - - @:mpifx_gatherv_dr1_template(i0i1, integer, , 1, (:), 1, MPI_INTEGER) - @:mpifx_gatherv_dr1_template(s0s1, real(sp), , 1, (:), 1, MPI_REAL) - @:mpifx_gatherv_dr1_template(d0d1, real(dp), , 1, (:), 1, MPI_DOUBLE_PRECISION) - @:mpifx_gatherv_dr1_template(c0c1, complex(sp), , 1, (:), 1, MPI_COMPLEX) - @:mpifx_gatherv_dr1_template(z0z1, complex(dp), , 1, (:), 1, MPI_DOUBLE_COMPLEX) - @:mpifx_gatherv_dr1_template(l0l1, logical, , 1, (:), 1, MPI_LOGICAL) + #: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 From d71e6924a9aba9f9e9321016f55442fb2e41823a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 3 Sep 2019 10:04:25 +0200 Subject: [PATCH 58/72] Clean up and fix make-based build as well --- make.arch.template | 15 ++++------ test/GNUmakefile | 68 ------------------------------------------- test/Makefile.targets | 29 ------------------ 3 files changed, 6 insertions(+), 106 deletions(-) delete mode 100644 test/GNUmakefile delete mode 100644 test/Makefile.targets diff --git a/make.arch.template b/make.arch.template index d424b41..df379e3 100644 --- a/make.arch.template +++ b/make.arch.template @@ -5,8 +5,8 @@ # Fortran 2003 compiler FXX = mpif90 -# Fortran compiler options -FXXOPT = -std=f2003 +# Fortran compiler otions +FXXOPT = # Linker LN = $(FXX) @@ -14,14 +14,11 @@ LN = $(FXX) # Linker options LNOPT = -# FYPP interpreter (see https://github.com/aradi/fypp) -FYPP = $(ROOT)/external/fypp/fypp +# M4 interpreter +FYPP = fypp -# FYPP interpreter options (e.g. -DDEBUG for debug mode) +# M4 interpreter options FYPPOPT = "" -# Directory where the build should happen +# Where to build the library (ROOT = root of the source distribution) BUILDDIR = $(ROOT)/_build - -# Where to copy files when installation is required -INSTALLDIR = $(ROOT)/_install diff --git a/test/GNUmakefile b/test/GNUmakefile deleted file mode 100644 index 5507bc4..0000000 --- a/test/GNUmakefile +++ /dev/null @@ -1,68 +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. -# -############################################################################ - -include ../make.arch - -# Directory where library source can be found -SRCDIR = ../src - -############################################################################ -# 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 - -TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ - test_allreduce test_gather test_gatherv test_allgather \ - test_allgatherv test_scatter - -all: $(TARGETS) - -# Create dependencies (make sure every targets .o file additionally depends on -# the external libary, as the library modfiles must been created first) -include Makefile.dep -$(TARGETS:=.o): _extlib_mpifx - -# Include linking rules for targets -define link-target -$(LN) $(LNOPT) -o $@ $(filter-out _%,$^) -L$(SRCDIR) -lmpifx -endef -include Makefile.targets - -%.o: %.f90 - $(FXX) $(FXXOPT) -I$(SRCDIR) -c $< - -.PHONY: clean realclean -clean: - $(MAKE) SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib clean - rm -f *.mod *.o _* - -distclean: clean - $(MAKE) SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib distclean - rm -f $(TARGETS) - - -############################################################################ -# Invoking the makefile of the library to build it in its directory -############################e################################################ -.PHONY: _FORCED_SUBMAKE_ - -_extlib_mpifx: _FORCED_SUBMAKE_ - touch -r $(SRCDIR)/libmpifx.a $@ - -_FORCED_SUBMAKE_: - $(MAKE) \ - FXX="$(FXX)" FXXOPT="$(FXXOPT)" \ - LN="$(LN)" LNOPT="$(LNOPT)" \ - M4="$(M4)" M4OPT="$(M4OPT)" \ - SRCDIR="$(SRCDIR)" -C $(SRCDIR) -f Makefile.lib diff --git a/test/Makefile.targets b/test/Makefile.targets deleted file mode 100644 index 08f66bd..0000000 --- a/test/Makefile.targets +++ /dev/null @@ -1,29 +0,0 @@ -test_bcast: $(test_bcast.o) - $(link-target) - -test_send_recv: $(test_send_recv.o) - $(link-target) - -test_comm_split: $(test_comm_split.o) - $(link-target) - -test_reduce: $(test_reduce.o) - $(link-target) - -test_allreduce: $(test_allreduce.o) - $(link-target) - -test_gather: $(test_gather.o) - $(link-target) - -test_gatherv: $(test_gatherv.o) - $(link-target) - -test_allgather: $(test_allgather.o) - $(link-target) - -test_allgatherv: $(test_allgatherv.o) - $(link-target) - -test_scatter: $(test_scatter.o) - $(link-target) From 06218ebb5f0f92fd48fc059214724e74f05d313b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 2 Oct 2019 16:53:04 +0200 Subject: [PATCH 59/72] Fix cmake issues --- lib/CMakeLists.txt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index c884ad1..bf0a05d 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -38,13 +38,16 @@ endif() add_library(mpifx ${sources-f90-preproc}) -set(includedir ${CMAKE_CURRENT_BINARY_DIR}/include) +set(BUILD_MOD_DIR ${CMAKE_CURRENT_BINARY_DIR}/include) -set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${includedir}) +set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${BUILD_MOD_DIR}) -target_include_directories(mpifx PUBLIC ${includedir}) +target_include_directories(mpifx PUBLIC + $ + $) install(TARGETS mpifx + EXPORT ${INSTALL_EXPORT_NAME} ARCHIVE DESTINATION ${INSTALL_LIB_DIR} LIBRARY DESTINATION ${INSTALL_LIB_DIR}) From ad6e1a64b199dc049d80fa0582e1d06d9dc6aef0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Thu, 31 Oct 2019 09:56:21 +0100 Subject: [PATCH 60/72] Fix broken include file installation --- CMakeLists.txt | 4 ++++ lib/CMakeLists.txt | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index f5c9678..64bc8b9 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,6 +4,10 @@ project(mpifx VERSION 0.1 LANGUAGES Fortran) set(LIBRARY_ONLY FALSE CACHE BOOL "Whether only library should be compiled") +option(BUILD_SHARED_LIBS "Whether the library should be a shared one" FALSE) + +option(INSTALL_INCLUDE_FILES "Whether include / module files should be installed" TRUE) + # Installation paths set(INSTALL_BIN_DIR "${CMAKE_INSTALL_PREFIX}/bin" CACHE PATH "Installation directory for executables") diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index bf0a05d..ed5e7a5 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -52,5 +52,5 @@ install(TARGETS mpifx LIBRARY DESTINATION ${INSTALL_LIB_DIR}) if(INSTALL_INCLUDE_FILES) - install(DIRECTORY ${includedir}/ DESTINATION ${INSTALL_MOD_DIR}) + install(DIRECTORY ${BUILD_MOD_DIR}/ DESTINATION ${INSTALL_MOD_DIR}) endif() From f033e93906837b76c45441830c2f6ff0da15a58b Mon Sep 17 00:00:00 2001 From: Gabriele Penazzi Date: Thu, 2 Jan 2020 07:28:34 +0100 Subject: [PATCH 61/72] Add mpi includes and linking For stand-alone shared library compilation --- lib/CMakeLists.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index ed5e7a5..986b53a 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -46,6 +46,9 @@ target_include_directories(mpifx PUBLIC $ $) +target_include_directories(mpifx PRIVATE ${MPI_Fortran_MODULE_DIR}) +target_link_libraries(mpifx PRIVATE ${MPI_Fortran_LIBRARIES}) + install(TARGETS mpifx EXPORT ${INSTALL_EXPORT_NAME} ARCHIVE DESTINATION ${INSTALL_LIB_DIR} From 7e128bb6d17db1dffa3838979e49d800d621c8f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Wed, 15 Jan 2020 17:04:10 +0100 Subject: [PATCH 62/72] Upgrade fypp, enchance local independent build --- external/fypp/{LICENSE => LICENSE.txt} | 2 +- external/fypp/README.rst | 36 ++-- external/fypp/fypp | 266 ++++++++++++++----------- lib/make.build | 2 +- 4 files changed, 174 insertions(+), 132 deletions(-) rename external/fypp/{LICENSE => LICENSE.txt} (95%) diff --git a/external/fypp/LICENSE b/external/fypp/LICENSE.txt similarity index 95% rename from external/fypp/LICENSE rename to external/fypp/LICENSE.txt index d64971f..a6a775c 100644 --- a/external/fypp/LICENSE +++ b/external/fypp/LICENSE.txt @@ -1,4 +1,4 @@ -Copyright (c) 2016-2017 Bálint Aradi, Universität Bremen +Copyright (c) 2016-2020 Bálint Aradi, Universität Bremen All rights reserved. diff --git a/external/fypp/README.rst b/external/fypp/README.rst index 2ccd6f4..ef72a35 100644 --- a/external/fypp/README.rst +++ b/external/fypp/README.rst @@ -37,20 +37,20 @@ Main features * Macro definitions and macro calls:: - #:def assertTrue(cond) - #:if DEBUG > 0 - if (.not. ${cond}$) then - print *, "Assert failed in file ${_FILE_}$, line ${_LINE_}$" - error stop - end if - #:endif - #:enddef assertTrue + #:def ASSERT(cond) + #:if DEBUG > 0 + if (.not. ${cond}$) then + print *, "Assert failed in file ${_FILE_}$, line ${_LINE_}$" + error stop + end if + #:endif + #:enddef ASSERT ! Invoked via direct call (argument needs no quotation) - @:assertTrue(size(myArray) > 0) + @:ASSERT(size(myArray) > 0) ! Invoked as Python expression (argument needs quotation) - $:assertTrue('size(myArray) > 0') + $:ASSERT('size(myArray) > 0') * Conditional output:: @@ -93,30 +93,30 @@ Main features * Passing (unquoted) multiline string arguments to callables:: #! Callable needs only string argument - #:def debug_code(code) + #:def DEBUG_CODE(code) #:if DEBUG > 0 $:code #:endif - #:enddef debug_code + #:enddef DEBUG_CODE #! Pass code block as first positional argument - #:call debug_code + #:block DEBUG_CODE if (size(array) > 100) then print *, "DEBUG: spuriously large array" end if - #:endcall debug_code + #:endblock DEBUG_CODE #! Callable needs also non-string argument types - #:def repeat_code(code, repeat) + #:def REPEAT_CODE(code, repeat) #:for ind in range(repeat) $:code #:endfor - #:enddef repeat_code + #:enddef REPEAT_CODE #! Pass code block as positional argument and 3 as keyword argument "repeat" - #:call repeat_code(repeat=3) + #:block REPEAT_CODE(repeat=3) this will be repeated 3 times - #:endcall repeat_code + #:endblock REPEAT_CODE * Preprocessor comments:: diff --git a/external/fypp/fypp b/external/fypp/fypp index a2c7965..31e5e32 100755 --- a/external/fypp/fypp +++ b/external/fypp/fypp @@ -4,7 +4,7 @@ # # fypp -- Python powered Fortran preprocessor # -# Copyright (c) 2017 Bálint Aradi, Universität Bremen +# Copyright (c) 2016-2020 Bálint Aradi, Universität Bremen # # All rights reserved. # @@ -60,6 +60,7 @@ import os import errno import time import optparse +import io if sys.version_info[0] >= 3: import builtins else: @@ -68,7 +69,7 @@ else: # Prevent cluttering user directory with Python bytecode sys.dont_write_bytecode = True -VERSION = '2.1.1' +VERSION = '3.0' STDIN = '' @@ -132,7 +133,9 @@ _CONTLINE_REGEXP = re.compile(r'&[ \t]*\n(?:[ \t]*&)?') _UNESCAPE_TEXT_REGEXP1 = re.compile(r'([$#@])\\(\\*)([{:])') -_UNESCAPE_TEXT_REGEXP2 = re.compile(r'(\})\\(\\*)([$#@])') +_UNESCAPE_TEXT_REGEXP2 = re.compile(r'#\\(\\*)([!])') + +_UNESCAPE_TEXT_REGEXP3 = re.compile(r'(\})\\(\\*)([$#@])') _INLINE_EVAL_REGION_REGEXP = re.compile(r'\${.*?}\$') @@ -208,12 +211,10 @@ class FyppError(Exception): class FyppFatalError(FyppError): '''Signalizes an unexpected error during processing.''' - pass class FyppStopRequest(FyppError): '''Signalizes an explicitely triggered stop (e.g. via stop directive)''' - pass class Parser: @@ -222,9 +223,11 @@ class Parser: Args: includedirs (list): List of directories, in which include files should be searched for, when they are not found at the default location. + + encoding (str): Encoding to use when reading the file (default: utf-8) ''' - def __init__(self, includedirs=None): + def __init__(self, includedirs=None, encoding='utf-8'): # Directories to search for include files if includedirs is None: @@ -232,6 +235,9 @@ class Parser: else: self._includedirs = includedirs + # Encoding + self._encoding = encoding + # Name of current file self._curfile = None @@ -249,7 +255,7 @@ class Parser: if fobj == STDIN: self._includefile(None, sys.stdin, STDIN, os.getcwd()) else: - inpfp = _open_input_file(fobj) + inpfp = _open_input_file(fobj, self._encoding) self._includefile(None, inpfp, fobj, os.path.dirname(fobj)) inpfp.close() else: @@ -261,9 +267,7 @@ class Parser: olddir = self._curdir self._curfile = fname self._curdir = curdir - self.handle_include(span, fname) - self._parse(fobj.read()) - self.handle_endinclude(span, fname) + self._parse_txt(span, fname, fobj.read()) self._curfile = oldfile self._curdir = olddir @@ -276,9 +280,7 @@ class Parser: ''' self._curfile = STRING self._curdir = '' - self.handle_include(None, self._curfile) - self._parse(txt) - self.handle_endinclude(None, self._curfile) + self._parse_txt(None, self._curfile, txt) def handle_include(self, span, fname): @@ -429,7 +431,7 @@ class Parser: self._log_event('endfor', span) - def handle_call(self, span, name, argexpr): + def handle_call(self, span, name, argexpr, blockcall): '''Called when parser encounters a call directive. It is a dummy method and should be overriden for actual use. @@ -439,11 +441,14 @@ class Parser: name (str): Name of the callable to call argexpr (str or None): Argument expression containing additional arguments for the call. + blockcall (bool): Whether the alternative "block / contains / + endblock" calling directive has been used. ''' - self._log_event('call', span, name=name, argexpr=argexpr) + self._log_event('call', span, name=name, argexpr=argexpr, + blockcall=blockcall) - def handle_nextarg(self, span, name): + def handle_nextarg(self, span, name, blockcall): '''Called when parser encounters a nextarg directive. It is a dummy method and should be overriden for actual use. @@ -452,11 +457,13 @@ class Parser: span (tuple of int): Start and end line of the directive. name (str or None): Name of the argument following next or None if it should be the next positional argument. + blockcall (bool): Whether the alternative "block / contains / + endblock" calling directive has been used. ''' - self._log_event('nextarg', span, name=name) + self._log_event('nextarg', span, name=name, blockcall=blockcall) - def handle_endcall(self, span, name): + def handle_endcall(self, span, name, blockcall): '''Called when parser encounters an endcall directive. It is a dummy method and should be overriden for actual use. @@ -464,8 +471,10 @@ class Parser: Args: span (tuple of int): Start and end line of the directive. name (str): Name found after the endcall directive. + blockcall (bool): Whether the alternative "block / contains / + endblock" calling directive has been used. ''' - self._log_event('endcall', span, name=name) + self._log_event('endcall', span, name=name, blockcall=blockcall) def handle_eval(self, span, expr): @@ -569,6 +578,12 @@ class Parser: print() + def _parse_txt(self, includespan, fname, txt): + self.handle_include(includespan, fname) + self._parse(txt) + self.handle_endinclude(includespan, fname) + + def _parse(self, txt, linenr=0, directcall=False): pos = 0 for match in _ALL_DIRECTIVES_REGEXP.finditer(txt): @@ -654,13 +669,13 @@ class Parser: elif directive == 'endfor': self._check_param_presence(False, 'endfor', param, span) self.handle_endfor(span) - elif directive == 'call': - self._check_param_presence(True, 'call', param, span) - self._process_call(param, span) - elif directive == 'nextarg': - self._process_nextarg(param, span) - elif directive == 'endcall': - self._process_endcall(param, span) + elif directive == 'call' or directive == 'block': + self._check_param_presence(True, directive, param, span) + self._process_call(param, span, directive == 'block') + elif directive == 'nextarg' or directive == 'contains': + self._process_nextarg(param, span, directive == 'contains') + elif directive == 'endcall' or directive == 'endblock': + self._process_endcall(param, span, directive == 'endblock') elif directive == 'include': self._check_param_presence(True, 'include', param, span) self._check_not_inline_directive('include', span) @@ -695,7 +710,7 @@ class Parser: msg = "invalid direct call expression" raise FyppFatalError(msg, self._curfile, span) callname = match.group('callname') - self.handle_call(span, callname, None) + self.handle_call(span, callname, None, False) callparams = match.group('callparams') if callparams is None or not callparams.strip(): args = [] @@ -712,9 +727,9 @@ class Parser: if argval.startswith('{'): argval = argval[1:-1] keyword = match.group('kwname') - self.handle_nextarg(span, keyword) + self.handle_nextarg(span, keyword, False) self._parse(argval, linenr=span[0], directcall=True) - self.handle_endcall(span, callname) + self.handle_endcall(span, callname, False) def _process_def(self, param, span): @@ -771,33 +786,33 @@ class Parser: self.handle_for(span, loopvars, match.group('iter')) - def _process_call(self, param, span): + def _process_call(self, param, span, blockcall): match = _SIMPLE_CALLABLE_REGEXP.match(param) if not match: msg = "invalid callable expression '{}'".format(param) raise FyppFatalError(msg, self._curfile, span) name, args = match.groups() - self.handle_call(span, name, args) + self.handle_call(span, name, args, blockcall) - def _process_nextarg(self, param, span): + def _process_nextarg(self, param, span, blockcall): if param is not None: match = _IDENTIFIER_NAME_REGEXP.match(param) if not match: msg = "invalid nextarg parameter '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) param = match.group('name') - self.handle_nextarg(span, param) + self.handle_nextarg(span, param, blockcall) - def _process_endcall(self, param, span): + def _process_endcall(self, param, span, blockcall): if param is not None: match = _PREFIXED_IDENTIFIER_NAME_REGEXP.match(param) if not match: msg = "invalid endcall parameter '{0}'".format(param) raise FyppFatalError(msg, self._curfile, span) param = match.group('name') - self.handle_endcall(span, param) + self.handle_endcall(span, param, blockcall) def _process_include(self, param, span): @@ -813,7 +828,7 @@ class Parser: else: msg = "include file '{0}' not found".format(fname) raise FyppFatalError(msg, self._curfile, span) - inpfp = _open_input_file(fpath) + inpfp = _open_input_file(fpath, self._encoding) self._includefile(span, inpfp, fpath, os.path.dirname(fpath)) inpfp.close() @@ -850,7 +865,8 @@ class Parser: @staticmethod def _unescape(txt): txt = _UNESCAPE_TEXT_REGEXP1.sub(r'\1\2\3', txt) - txt = _UNESCAPE_TEXT_REGEXP2.sub(r'\1\2\3', txt) + txt = _UNESCAPE_TEXT_REGEXP2.sub(r'#\1\2', txt) + txt = _UNESCAPE_TEXT_REGEXP3.sub(r'\1\2\3', txt) return txt @@ -1073,7 +1089,7 @@ class Builder: self._curnode.append(block) - def handle_call(self, span, name, argexpr): + def handle_call(self, span, name, argexpr, blockcall): '''Should be called to signalize a call directive. Args: @@ -1081,26 +1097,34 @@ class Builder: name (str): Name of the callable to call argexpr (str or None): Argument expression containing additional arguments for the call. + blockcall (bool): Whether the alternative "block / contains / + endblock" calling directive has been used. ''' self._path.append(self._curnode) self._curnode = [] + directive = 'block' if blockcall else 'call' self._open_blocks.append( - ('call', self._curfile, [span, span], name, argexpr, [], [])) + (directive, self._curfile, [span, span], name, argexpr, [], [])) - def handle_nextarg(self, span, name): + def handle_nextarg(self, span, name, blockcall): '''Should be called to signalize a nextarg directive. Args: span (tuple of int): Start and end line of the directive. name (str or None): Name of the argument following next or None if it should be the next positional argument. + blockcall (bool): Whether the alternative "block / contains / + endblock" calling directive has been used. ''' self._check_for_open_block(span, 'nextarg') block = self._open_blocks[-1] directive, fname, spans = block[0:3] - self._check_if_matches_last( - directive, 'call', spans[-1], span, 'nextarg') + if blockcall: + opened, current = 'block', 'contains' + else: + opened, current = 'call', 'nextarg' + self._check_if_matches_last(directive, opened, spans[-1], span, current) args, argnames = block[5:7] args.append(self._curnode) spans.append(span) @@ -1112,23 +1136,29 @@ class Builder: self._curnode = [] - def handle_endcall(self, span, name): + def handle_endcall(self, span, name, blockcall): '''Should be called to signalize an endcall directive. Args: span (tuple of int): Start and end line of the directive. name (str): Name of the endcall statement. Could be None, if endcall was specified without name. + blockcall (bool): Whether the alternative "block / contains / + endblock" calling directive has been used. ''' self._check_for_open_block(span, 'endcall') block = self._open_blocks.pop(-1) directive, fname, spans = block[0:3] - self._check_if_matches_last(directive, 'call', spans[0], span, - 'endcall') callname, callargexpr, args, argnames = block[3:7] + if blockcall: + opened, current = 'block', 'endblock' + else: + opened, current = 'call', 'endcall' + self._check_if_matches_last(directive, opened, spans[0], span, current) + if name is not None and name != callname: - msg = "wrong name in endcall directive "\ - "(expected '{0}', got '{1}')".format(callname, name) + msg = "wrong name in {0} directive "\ + "(expected '{1}', got '{2}')".format(current, callname, name) raise FyppFatalError(msg, fname, span) args.append(self._curnode) # If nextarg or endcall immediately followed call, then first argument @@ -1350,13 +1380,13 @@ class Renderer: ''' diverted = self._diverted self._diverted = divert - fixedposition = self._fixedposition - self._fixedposition = fixposition + fixedposition_old = self._fixedposition + self._fixedposition = self._fixedposition or fixposition output, eval_inds, eval_pos = self._render(tree) if not self._diverted and eval_inds: self._postprocess_eval_lines(output, eval_inds, eval_pos) self._diverted = diverted - self._fixedposition = fixedposition + self._fixedposition = fixedposition_old txt = ''.join(output) return txt @@ -1393,7 +1423,7 @@ class Renderer: eval_inds += _shiftinds(ieval, len(output)) eval_pos += peval output += out - elif cmd == 'call': + elif cmd == 'call' or cmd == 'block': out, ieval, peval = self._get_called_content(*node[1:7]) eval_inds += _shiftinds(ieval, len(output)) eval_pos += peval @@ -1580,7 +1610,8 @@ class Renderer: if argexpr is None: args = [] defaults = {} - varargs = None + varpos = None + varkw = None else: # Try to create a lambda function with the argument expression self._evaluator.openscope() @@ -1593,11 +1624,12 @@ class Renderer: raise FyppFatalError(msg, fname, spans[0], exc) self._evaluator.closescope() try: - args, defaults, varargs = _get_callable_argspec(func) + args, defaults, varpos, varkw = _GET_CALLABLE_ARGSPEC(func) except Exception as exc: msg = "invalid argument expression '{0}'".format(argexpr) raise FyppFatalError(msg, fname, spans[0], exc) - named_args = args if varargs is None else args + [varargs] + named_args = args if varpos is None else args + [varpos] + named_args = named_args if varkw is None else named_args + [varkw] for arg in named_args: if arg in _RESERVED_NAMES or arg.startswith(_RESERVED_PREFIX): msg = "invalid argument name '{0}'".format(arg) @@ -1605,8 +1637,8 @@ class Renderer: result = '' try: macro = _Macro( - name, fname, spans, args, defaults, varargs, content, self, - self._evaluator, self._evaluator.localscope) + name, fname, spans, args, defaults, varpos, varkw, content, + self, self._evaluator, self._evaluator.localscope) self._define(name, macro) except Exception as exc: msg = "exception occured when defining macro '{0}'"\ @@ -1666,16 +1698,14 @@ class Renderer: def _get_comment(self, fname, span): if self._linenums and not self._diverted: return linenumdir(span[1], fname) - else: - return '' + return '' def _get_muted_content(self, fname, spans, content): self._render(content) if self._linenums and not self._diverted: return linenumdir(spans[-1][1], fname) - else: - return '' + return '' def _handle_stop(self, fname, span, msgstr): @@ -1825,8 +1855,7 @@ class Renderer: def _foldline(self, line): if _COMMENTLINE_REGEXP.match(line) is None: return self._linefolder(line) - else: - return [line] + return [line] class Evaluator: @@ -2181,10 +2210,8 @@ class Evaluator: module = self._scope.get(name, None) if module is not None and isinstance(module, types.ModuleType): return module - else: - msg = "Import of module '{0}' via '__import__' not allowed"\ - .format(name) - raise ImportError(msg) + msg = "Import of module '{0}' via '__import__' not allowed".format(name) + raise ImportError(msg) def _func_setvar(self, *namesvalues): @@ -2198,8 +2225,7 @@ class Evaluator: def _func_getvar(self, name, defvalue=None): if name in self._scope: return self._scope[name] - else: - return defvalue + return defvalue def _func_delvar(self, *names): @@ -2230,7 +2256,8 @@ class _Macro: fname (str): The file where the macro was defined. spans (str): Line spans of macro defintion. argnames (list of str): Macro dummy arguments. - varargs (str): Name of variable positional arguments or None. + varpos (str): Name of variable positional argument or None. + varkw (str): Name of variable keyword argument or None. content (list): Content of the macro as tree. renderer (Renderer): Renderer to use for evaluating macro content. localscope (dict): Dictionary with local variables, which should be used @@ -2238,14 +2265,15 @@ class _Macro: local scope). ''' - def __init__(self, name, fname, spans, argnames, defaults, varargs, content, - renderer, evaluator, localscope=None): + def __init__(self, name, fname, spans, argnames, defaults, varpos, varkw, + content, renderer, evaluator, localscope=None): self._name = name self._fname = fname self._spans = spans self._argnames = argnames self._defaults = defaults - self._varargs = varargs + self._varpos = varpos + self._varkw = varkw self._content = content self._renderer = renderer self._evaluator = evaluator @@ -2261,43 +2289,46 @@ class _Macro: self._evaluator.closescope() if output.endswith('\n'): return output[:-1] - else: - return output + return output def _process_arguments(self, args, keywords): + kwdict = dict(keywords) argdict = {} nargs = min(len(args), len(self._argnames)) for iarg in range(nargs): argdict[self._argnames[iarg]] = args[iarg] if nargs < len(args): - if self._varargs is None: + if self._varpos is None: msg = "macro '{0}' called with too many positional arguments "\ "(expected: {1}, received: {2})"\ .format(self._name, len(self._argnames), len(args)) raise FyppFatalError(msg, self._fname, self._spans[0]) else: - argdict[self._varargs] = tuple(args[nargs:]) - elif self._varargs is not None: - argdict[self._varargs] = () + argdict[self._varpos] = list(args[nargs:]) + elif self._varpos is not None: + argdict[self._varpos] = [] for argname in self._argnames[:nargs]: - if argname in keywords: + if argname in kwdict: msg = "got multiple values for argument '{0}'".format(argname) raise FyppFatalError(msg, self._fname, self._spans[0]) - if self._varargs is not None and self._varargs in keywords: - msg = "got unexpected keyword argument '{0}'".format(self._varargs) - raise FyppFatalError(msg, self._fname, self._spans[0]) - argdict.update(keywords) if nargs < len(self._argnames): for argname in self._argnames[nargs:]: - if argname in argdict: - pass + if argname in kwdict: + argdict[argname] = kwdict.pop(argname) elif argname in self._defaults: argdict[argname] = self._defaults[argname] else: msg = "macro '{0}' called without mandatory positional "\ "argument '{1}'".format(self._name, argname) raise FyppFatalError(msg, self._fname, self._spans[0]) + if kwdict and self._varkw is None: + kwstr = "', '".join(kwdict.keys()) + msg = "macro '{0}' called with unknown keyword argument(s) '{1}'"\ + .format(self._name, kwstr) + raise FyppFatalError(msg, self._fname, self._spans[0]) + if self._varkw is not None: + argdict[self._varkw] = kwdict return argdict @@ -2439,12 +2470,13 @@ class Fypp: if options is None: options = FyppOptions() evaluator = Evaluator() + self._encoding = options.encoding if options.modules: self._import_modules(options.modules, evaluator, syspath, options.moduledirs) if options.defines: self._apply_definitions(options.defines, evaluator) - parser = Parser(options.includes) + parser = Parser(includedirs=options.includes, encoding=self._encoding) builder = Builder() fixed_format = options.fixed_format @@ -2486,14 +2518,15 @@ class Fypp: output = self._preprocessor.process_file(infile) if outfile is None: return output + if outfile == '-': + outfile = sys.stdout else: - if outfile == '-': - outfile = sys.stdout - else: - outfile = _open_output_file(outfile, self._create_parent_folder) - outfile.write(output) - if outfile != sys.stdout: - outfile.close() + outfile = _open_output_file(outfile, self._encoding, + self._create_parent_folder) + outfile.write(output) + if outfile != sys.stdout: + outfile.close() + return None def process_text(self, txt): @@ -2579,6 +2612,11 @@ class FyppOptions(optparse.Values): standard module locations in sys.path. fixed_format (bool): Whether input file is in fixed format. Default: False. + encoding (str): Character encoding for reading/writing files. Allowed + values are Pythons codec identifiers, e.g. 'ascii', 'utf-8', etc. + Default: 'utf-8'. Reading from stdin and writing to stdout is always + encoded according to the current locale and is not affected by this + setting. create_parent_folder (bool): Whether the parent folder for the output file should be created if it does not exist. Default: False. ''' @@ -2597,6 +2635,7 @@ class FyppOptions(optparse.Values): self.modules = [] self.moduledirs = [] self.fixed_format = False + self.encoding = 'utf-8' self.create_parent_folder = False @@ -2702,8 +2741,7 @@ class FortranLineFolder: # The space we waste for smart folding should be max. 1/3rd of the line if ispace != -1 and ispace >= start + (2 * linelen) // 3: return ispace - else: - return end + return end class DummyLineFolder: @@ -2792,6 +2830,11 @@ def get_option_parser(): '--line-length, --folding-method and --indentation are ignored)' parser.add_option('--fixed-format', action='store_true', dest='fixed_format', default=defs.fixed_format, help=msg) + msg = 'character encoding for reading/writing files. Default: \'utf-8\'. '\ + 'Note: reading from stdin and writing to stdout is encoded '\ + 'according to the current locale and is not affected by this setting.' + parser.add_option('--encoding', metavar='ENC', default=defs.encoding, + help=msg) msg = 'create parent folders of the output file if they do not exist' parser.add_option('-p', '--create-parents', action='store_true', dest='create_parent_folder', @@ -2826,24 +2869,23 @@ def linenumdir(linenr, fname, flag=None): ''' if flag is None: return '# {0} "{1}"\n'.format(linenr + 1, fname) - else: - return '# {0} "{1}" {2}\n'.format(linenr + 1, fname, flag) + return '# {0} "{1}" {2}\n'.format(linenr + 1, fname, flag) def _shiftinds(inds, shift): return [ind + shift for ind in inds] -def _open_input_file(inpfile): +def _open_input_file(inpfile, encoding=None): try: - inpfp = open(inpfile, 'r') + inpfp = io.open(inpfile, 'r', encoding=encoding) except IOError as exc: msg = "Failed to open file '{0}' for read".format(inpfile) raise FyppFatalError(msg, cause=exc) return inpfp -def _open_output_file(outfile, create_parents=False): +def _open_output_file(outfile, encoding=None, create_parents=False): if create_parents: parentdir = os.path.abspath(os.path.dirname(outfile)) if not os.path.exists(parentdir): @@ -2855,7 +2897,7 @@ def _open_output_file(outfile, create_parents=False): .format(parentdir) raise FyppFatalError(msg, cause=exc) try: - outfp = open(outfile, 'w') + outfp = io.open(outfile, 'w', encoding=encoding) except IOError as exc: msg = "Failed to open file '{0}' for write".format(outfile) raise FyppFatalError(msg, cause=exc) @@ -2864,11 +2906,8 @@ def _open_output_file(outfile, create_parents=False): def _get_callable_argspec_py2(func): argspec = inspect.getargspec(func) - if argspec.keywords is not None: - msg = "variable length keyword argument '{0}' found"\ - .format(argspec.keywords) - raise FyppFatalError(msg) - vararg = argspec.varargs + varpos = argspec.varargs + varkw = argspec.keywords args = argspec.args tuplearg = False for elem in args: @@ -2881,33 +2920,36 @@ def _get_callable_argspec_py2(func): for ind, default in enumerate(argspec.defaults): iarg = len(args) - len(argspec.defaults) + ind defaults[args[iarg]] = default - return args, defaults, vararg + return args, defaults, varpos, varkw def _get_callable_argspec_py3(func): sig = inspect.signature(func) args = [] defaults = {} - vararg = None + varpos = None + varkw = None for param in sig.parameters.values(): if param.kind == param.POSITIONAL_OR_KEYWORD: args.append(param.name) if param.default != param.empty: defaults[param.name] = param.default elif param.kind == param.VAR_POSITIONAL: - vararg = param.name + varpos = param.name + elif param.kind == param.VAR_KEYWORD: + varkw = param.name else: msg = "argument '{0}' has invalid argument type".format(param.name) raise FyppFatalError(msg) - return args, defaults, vararg + return args, defaults, varpos, varkw # Signature objects are available from Python 3.3 (and deprecated from 3.5) if sys.version_info[0] >= 3 and sys.version_info[1] >= 3: - _get_callable_argspec = _get_callable_argspec_py3 + _GET_CALLABLE_ARGSPEC = _get_callable_argspec_py3 else: - _get_callable_argspec = _get_callable_argspec_py2 + _GET_CALLABLE_ARGSPEC = _get_callable_argspec_py2 def _blank_match(match): diff --git a/lib/make.build b/lib/make.build index 16293c5..328ef96 100644 --- a/lib/make.build +++ b/lib/make.build @@ -33,7 +33,7 @@ $(TARGET): $(module.o) ar r $@ $^ %.f90: %.fpp - $(FYPP) -I$(SRCDIR) $(FYPPOPT) $< > $@ + $(FYPP) -I$(SRCDIR) $(FYPPOPT) $< $@ %.o: %.f90 $(FXX) $(FXXOPT) -c $< From 5cfe6a8e2320080b22581bbefc486e7eff82d54f Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Thu, 23 Jan 2020 23:04:25 +0000 Subject: [PATCH 63/72] Scatterv and test added --- lib/CMakeLists.txt | 1 + lib/make.deps | 8 +- lib/module.fpp | 1 + lib/mpifx_scatterv.fpp | 217 +++++++++++++++++++++++++++++++++++++++++ test/CMakeLists.txt | 3 +- test/make.build | 6 +- test/make.deps | 3 + test/test_scatterv.f90 | 85 ++++++++++++++++ 8 files changed, 320 insertions(+), 4 deletions(-) create mode 100644 lib/mpifx_scatterv.fpp create mode 100644 test/test_scatterv.f90 diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index 986b53a..f373dc2 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -18,6 +18,7 @@ set(sources-fpp mpifx_recv.fpp mpifx_reduce.fpp mpifx_scatter.fpp + mpifx_scatterv.fpp mpifx_send.fpp) set(sources-f90-preproc) diff --git a/lib/make.deps b/lib/make.deps index 34e8f62..6a29eb7 100644 --- a/lib/make.deps +++ b/lib/make.deps @@ -36,8 +36,8 @@ mpifx_constants.o: $$(_modobj_mpi) mpifx_constants.o = mpifx_constants.o $($(_modobj_mpi)) _modobj_mpifx_constants_module = mpifx_constants.o -module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_allgatherv_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_allgatherv_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) +module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_scatterv_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_allgatherv_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) +module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_scatterv_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_allgatherv_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) _modobj_libmpifx_module = module.o @@ -69,6 +69,10 @@ mpifx_scatter.o: $$(_modobj_mpifx_common_module) mpifx_scatter.o = mpifx_scatter.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_scatter_module = mpifx_scatter.o +mpifx_scatterv.o: $$(_modobj_mpifx_common_module) +mpifx_scatterv.o = mpifx_scatterv.o $($(_modobj_mpifx_common_module)) +_modobj_mpifx_scatterv_module = mpifx_scatterv.o + mpifx_abort.o: $$(_modobj_mpifx_common_module) mpifx_abort.o = mpifx_abort.o $($(_modobj_mpifx_common_module)) _modobj_mpifx_abort_module = mpifx_abort.o diff --git a/lib/module.fpp b/lib/module.fpp index bdf5def..a121129 100644 --- a/lib/module.fpp +++ b/lib/module.fpp @@ -29,6 +29,7 @@ module libmpifx_module use mpifx_allgather_module use mpifx_allgatherv_module use mpifx_scatter_module + use mpifx_scatterv_module implicit none public diff --git a/lib/mpifx_scatterv.fpp b/lib/mpifx_scatterv.fpp new file mode 100644 index 0000000..ebe1a6e --- /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%master) 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%master) 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%masterrank) + !! \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%master .or. size(send) == size(recv) * mycomm%size) + @:ASSERT(.not. mycomm%master& + & .or. size(send, dim=${RANK}$) == size(recv, dim=${RANK}$) * mycomm%size) + + call getoptarg(mycomm%masterrank, 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%masterrank) + !! \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%master .or. size(send) == ${SIZE}$ * mycomm%size) + @:ASSERT(.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%size) + #:if HASLENGTH + @:ASSERT(.not. mycomm%master .or. len(send) == len(recv)) + #:endif + + call getoptarg(mycomm%masterrank, 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/test/CMakeLists.txt b/test/CMakeLists.txt index 243a4f0..efaf04f 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -7,7 +7,8 @@ set(targets test_gather test_gatherv test_reduce - test_scatter) + test_scatter + test_scatterv) foreach(target IN LISTS targets) add_executable(${target} ${target}.f90) diff --git a/test/make.build b/test/make.build index b85ee87..4a0f8ef 100644 --- a/test/make.build +++ b/test/make.build @@ -19,7 +19,8 @@ .SUFFIXES: .f90 .o TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ - test_allreduce test_gather test_allgather test_scatter + test_allreduce test_gather test_allgather test_scatter \ + test_scatterv all: $(TARGETS) @@ -71,3 +72,6 @@ test_allgather: $(test_allgather.o) test_scatter: $(test_scatter.o) $(link-target) + +test_scatterv: $(test_scatterv.o) + $(link-target) diff --git a/test/make.deps b/test/make.deps index ffbb367..e2d11be 100644 --- a/test/make.deps +++ b/test/make.deps @@ -21,6 +21,9 @@ test_bcast.o = test_bcast.o $($(_modobj_libmpifx_module)) test_scatter.o: $$(_modobj_libmpifx_module) test_scatter.o = test_scatter.o $($(_modobj_libmpifx_module)) +test_scatterv.o: $$(_modobj_libmpifx_module) +test_scatterv.o = test_scatterv.o $($(_modobj_libmpifx_module)) + test_comm_split.o: $$(_modobj_libmpifx_module) test_comm_split.o = test_comm_split.o $($(_modobj_libmpifx_module)) diff --git a/test/test_scatterv.f90 b/test/test_scatterv.f90 new file mode 100644 index 0000000..53b08c8 --- /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%master) 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%master) 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%master) 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%master) 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 From 9a2a9272f9b121a0f0d4b67622d0316c0b5f0a83 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Wed, 26 Feb 2020 09:36:09 +0000 Subject: [PATCH 64/72] Removed dftd3 from module install path --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 64bc8b9..7cb8a1c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -15,7 +15,7 @@ set(INSTALL_BIN_DIR "${CMAKE_INSTALL_PREFIX}/bin" CACHE PATH set(INSTALL_LIB_DIR "${CMAKE_INSTALL_PREFIX}/lib" CACHE PATH "Installation directory for libraries") -set(INSTALL_MOD_DIR "${CMAKE_INSTALL_PREFIX}/include/dftd3" CACHE PATH +set(INSTALL_MOD_DIR "${CMAKE_INSTALL_PREFIX}/include" CACHE PATH "Installation directory for Fortran module files") set(INSTALL_CMAKE_DIR "${CMAKE_INSTALL_PREFIX}/lib/cmake" CACHE PATH From a09191060e6c04d9dc867c1062b91e6c1ad8e97f Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Mon, 15 Jun 2020 20:41:24 +0100 Subject: [PATCH 65/72] IETF aricle 19 naming suggestion --- doc/sphinx/about.rst | 2 +- external/fypp/README.rst | 2 +- lib/mpifx_allgatherv.fpp | 2 +- lib/mpifx_bcast.fpp | 6 +++--- lib/mpifx_comm.fpp | 8 ++++---- lib/mpifx_gather.fpp | 28 ++++++++++++++-------------- lib/mpifx_gatherv.fpp | 12 ++++++------ lib/mpifx_recv.fpp | 6 +++--- lib/mpifx_reduce.fpp | 8 ++++---- lib/mpifx_scatter.fpp | 24 ++++++++++++------------ lib/mpifx_scatterv.fpp | 22 +++++++++++----------- lib/mpifx_send.fpp | 6 +++--- test/test_bcast.f90 | 10 +++++----- test/test_gather.f90 | 12 ++++++------ test/test_gatherv.f90 | 24 ++++++++++++------------ test/test_scatter.f90 | 6 +++--- test/test_scatterv.f90 | 8 ++++---- test/test_send_recv.f90 | 6 +++--- 18 files changed, 96 insertions(+), 96 deletions(-) diff --git a/doc/sphinx/about.rst b/doc/sphinx/about.rst index a151bf0..4feff63 100644 --- a/doc/sphinx/about.rst +++ b/doc/sphinx/about.rst @@ -17,7 +17,7 @@ Additional to the object to be broadcasted and the communicator, you also - size of the array (which is redundant, as it is *known* at run-time) -- root node of the broadcast (setting it to the master node as default would +- 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 diff --git a/external/fypp/README.rst b/external/fypp/README.rst index ef72a35..44bfd28 100644 --- a/external/fypp/README.rst +++ b/external/fypp/README.rst @@ -199,7 +199,7 @@ repository:: git clone https://github.com/aradi/fypp.git -and check out the `master` branch. +and check out the default main branch. The command line tool is a single stand-alone script. You can run it directly from the source folder :: diff --git a/lib/mpifx_allgatherv.fpp b/lib/mpifx_allgatherv.fpp index b64fe4c..55898bb 100644 --- a/lib/mpifx_allgatherv.fpp +++ b/lib/mpifx_allgatherv.fpp @@ -159,7 +159,7 @@ module mpifx_allgatherv_module !! !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) !! call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) - !! if (mycomm%master) then + !! if (mycomm%lead) then !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 !! end if !! diff --git a/lib/mpifx_bcast.fpp b/lib/mpifx_bcast.fpp index 6ce66d4..264c1fb 100644 --- a/lib/mpifx_bcast.fpp +++ b/lib/mpifx_bcast.fpp @@ -28,7 +28,7 @@ module mpifx_bcast_module !! integer :: buffer(3) !! !! call mycomm%init() - !! if (mycomm%master) then + !! if (mycomm%lead) then !! buffer(:) = [ 1, 2, 3 ] !! end if !! call mpifx_bcast(mycomm, buffer) @@ -61,7 +61,7 @@ contains !> Msg to be broadcasted on root and received on non-root nodes. ${TYPE}$ :: msg${RANKSUFFIX(RANK)}$ - !> Root node for the broadcast (default: mycomm%masterrank). + !> Root node for the broadcast (default: mycomm%leadrank). integer, intent(in), optional :: root !> Optional error handling flag. @@ -72,7 +72,7 @@ contains #:set SIZE = '1' if RANK == 0 else 'size(msg)' #:set COUNT = ('len(msg) * ' + SIZE if HASLENGTH else SIZE) - call getoptarg(mycomm%masterrank, root0, root) + 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) diff --git a/lib/mpifx_comm.fpp b/lib/mpifx_comm.fpp index fcf6306..eb3f5a1 100644 --- a/lib/mpifx_comm.fpp +++ b/lib/mpifx_comm.fpp @@ -12,8 +12,8 @@ module mpifx_comm_module integer :: id !< Communicator id. integer :: size !< Nr. of processes (size). integer :: rank !< Rank of the current process. - integer :: masterrank !< Index of the master node. - logical :: master !< True if current process is the master (rank == 0). + 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 @@ -50,8 +50,8 @@ contains if (error0 /= 0) then return end if - self%masterrank = 0 - self%master = (self%rank == self%masterrank) + self%leadrank = 0 + self%lead = (self%rank == self%leadrank) end subroutine mpifx_comm_init diff --git a/lib/mpifx_gather.fpp b/lib/mpifx_gather.fpp index 98593c2..b79bc2a 100644 --- a/lib/mpifx_gather.fpp +++ b/lib/mpifx_gather.fpp @@ -43,7 +43,7 @@ module mpifx_gather_module !! !! ! I0 -> I1 !! send0 = mycomm%rank * 2 ! Arbitrary number to send - !! if (mycomm%master) then + !! if (mycomm%lead) then !! allocate(recv1(1 * mycomm%size)) !! recv1(:) = 0 !! else @@ -51,7 +51,7 @@ module mpifx_gather_module !! end if !! write(*, *) mycomm%rank, "Send0 buffer:", send0 !! call mpifx_gather(mycomm, send0, recv1) - !! if (mycomm%master) then + !! if (mycomm%lead) then !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1(:) !! end if !! deallocate(recv1) @@ -59,7 +59,7 @@ module mpifx_gather_module !! ! I1 -> I1 !! allocate(send1(2)) !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers - !! if (mycomm%master) then + !! if (mycomm%lead) then !! allocate(recv1(size(send1) * mycomm%size)) !! recv1(:) = 0 !! else @@ -67,19 +67,19 @@ module mpifx_gather_module !! end if !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) !! call mpifx_gather(mycomm, send1, recv1) - !! if (mycomm%master) then + !! if (mycomm%lead) then !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 !! end if !! !! ! I1 -> I2 !! send1(:) = [ mycomm%rank, mycomm%rank + 1 ] - !! if (mycomm%master) then + !! 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%master) then + !! if (mycomm%lead) then !! write(*, *) mycomm%rank, "Recv2 buffer:", recv2 !! end if !! @@ -112,7 +112,7 @@ contains !! \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%masterrank) + !! \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) @@ -127,11 +127,11 @@ contains #:set SIZE = 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ASSERT(.not. mycomm%master .or. size(recv) == size(send) * mycomm%size) - @:ASSERT(.not. mycomm%master .or.& + @: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%masterrank, root0, root) + 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) @@ -150,7 +150,7 @@ contains !! \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%masterrank) + !! \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) @@ -165,10 +165,10 @@ contains #:set SIZE = '1' if RANK == 0 else 'size(send)' #:set COUNT = ('len(send) * ' + SIZE if HASLENGTH else SIZE) - @:ASSERT(.not. mycomm%master .or. size(recv) == ${SIZE}$ * mycomm%size) - @:ASSERT(.not. mycomm%master .or. size(recv, dim=${RANK + 1}$) == mycomm%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%masterrank, root0, root) + 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) diff --git a/lib/mpifx_gatherv.fpp b/lib/mpifx_gatherv.fpp index 9cd8378..c1cb677 100644 --- a/lib/mpifx_gatherv.fpp +++ b/lib/mpifx_gatherv.fpp @@ -17,7 +17,7 @@ !! \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%masterrank) + !! \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) @@ -33,7 +33,7 @@ integer, allocatable :: displs0(:) logical, allocatable :: testBuffer(:) - @:inoptflags(root0, root, mycomm%masterrank) + @:inoptflags(root0, root, mycomm%leadrank) if (mycomm%rank == root0) then allocate(displs0(mycomm%size)) @@ -87,7 +87,7 @@ !! \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%masterrank) + !! \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) @@ -102,7 +102,7 @@ integer :: ii, root0, error0 integer, allocatable :: displs0(:) - @:inoptflags(root0, root, mycomm%masterrank) + @:inoptflags(root0, root, mycomm%leadrank) if (mycomm%rank == root0) then @:ASSERT(size(recv) == sum(recvcounts)) @@ -173,7 +173,7 @@ module mpifx_gatherv_module !! ! I1 -> I1 !! allocate(send1(mycomm%rank+1)) !! send1 = 1.0*mycomm%rank - !! if (mycomm%master) then + !! if (mycomm%lead) then !! ! recv1 size is 1+2+3+...+mycomm%size !! nrecv = mycomm%size*(mycomm%size+1)/2 !! allocate(recv1(nrecv)) @@ -188,7 +188,7 @@ module mpifx_gatherv_module !! !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) !! call mpifx_gatherv(mycomm, send1, recv1, recvcounts) - !! if (mycomm%master) then + !! if (mycomm%lead) then !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 !! end if !! diff --git a/lib/mpifx_recv.fpp b/lib/mpifx_recv.fpp index fd91f23..d5ec093 100644 --- a/lib/mpifx_recv.fpp +++ b/lib/mpifx_recv.fpp @@ -33,11 +33,11 @@ module mpifx_recv_module !! !! call mpifx_init() !! call mycomm%init() - !! if (.not. mycomm%master) then + !! if (.not. mycomm%lead) then !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" - !! call mpifx_send(mycomm, msg, mycomm%masterrank) + !! call mpifx_send(mycomm, msg, mycomm%leadrank) !! else - !! write(*, "(A)") "Master node:" + !! write(*, "(A)") "Lead node:" !! do source = 1, mycomm%size - 1 !! call mpifx_recv(mycomm, msg, source) !! write(*,"(A,A)") "Message received: ", trim(msg) diff --git a/lib/mpifx_reduce.fpp b/lib/mpifx_reduce.fpp index d2f3ff1..b14fdb3 100644 --- a/lib/mpifx_reduce.fpp +++ b/lib/mpifx_reduce.fpp @@ -109,7 +109,7 @@ contains !! \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%masterrank) + !! \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) @@ -122,7 +122,7 @@ contains integer :: root0, error0 - call getoptarg(mycomm%masterrank, root0, root) + call getoptarg(mycomm%leadrank, root0, root) #:set SIZE = '1' if RANK == 0 else 'size(orig)' #:set COUNT = SIZE @@ -144,7 +144,7 @@ contains !! \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%masterrank) + !! \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) @@ -157,7 +157,7 @@ contains integer :: root0, error0 ${TYPE}$ :: dummy - call getoptarg(mycomm%masterrank, root0, root) + call getoptarg(mycomm%leadrank, root0, root) #:set SIZE = '1' if RANK == 0 else 'size(origred)' #:set COUNT = SIZE diff --git a/lib/mpifx_scatter.fpp b/lib/mpifx_scatter.fpp index 848fd04..de288b9 100644 --- a/lib/mpifx_scatter.fpp +++ b/lib/mpifx_scatter.fpp @@ -41,7 +41,7 @@ module mpifx_scatter_module !! call mycomm%init() !! !! ! I1 -> I0 - !! if (mycomm%master) then + !! if (mycomm%lead) then !! allocate(send1(mycomm%size)) !! send1(:) = [ (ii, ii = 1, size(send1)) ] !! write(*, *) mycomm%rank, "Send1 buffer:", send1 @@ -53,7 +53,7 @@ module mpifx_scatter_module !! write(*, *) mycomm%rank, "Recv0 buffer:", recv0 !! !! ! I1 -> I1 - !! if (mycomm%master) then + !! if (mycomm%lead) then !! deallocate(send1) !! allocate(send1(2 * mycomm%size)) !! send1(:) = [ (ii, ii = 1, size(send1)) ] @@ -65,7 +65,7 @@ module mpifx_scatter_module !! write(*, *) mycomm%rank, "Recv1 buffer:", recv1 !! !! ! I2 -> I1 - !! if (mycomm%master) then + !! if (mycomm%lead) then !! allocate(send2(2, mycomm%size)) !! send2(:,:) = reshape(send1, [ 2, mycomm%size ]) !! write(*, *) mycomm%rank, "Send2 buffer:", send2 @@ -101,7 +101,7 @@ contains !! \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%masterrank) + !! \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) @@ -116,11 +116,11 @@ contains #:set SIZE = 'size(recv)' #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) - @:ASSERT(.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) - @:ASSERT(.not. mycomm%master& + @: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%masterrank, root0, root) + 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) @@ -139,7 +139,7 @@ contains !! \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%masterrank) + !! \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) @@ -154,13 +154,13 @@ contains #:set SIZE = '1' if RANK == 1 else 'size(recv)' #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) - @:ASSERT(.not. mycomm%master .or. size(send) == ${SIZE}$ * mycomm%size) - @:ASSERT(.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%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%master .or. len(send) == len(recv)) + @:ASSERT(.not. mycomm%lead .or. len(send) == len(recv)) #:endif - call getoptarg(mycomm%masterrank, root0, root) + 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) diff --git a/lib/mpifx_scatterv.fpp b/lib/mpifx_scatterv.fpp index ebe1a6e..aaa4944 100644 --- a/lib/mpifx_scatterv.fpp +++ b/lib/mpifx_scatterv.fpp @@ -43,7 +43,7 @@ module mpifx_scatterv_module !! ! I1 -> I1 !! allocate(recv1(mycomm%rank+1)) !! recv1 = 0 - !! if (mycomm%master) then + !! if (mycomm%lead) then !! ! send1 size is 1+2+3+...+mycomm%size !! nsend = mycomm%size*(mycomm%size+1)/2 !! allocate(send1(nsend)) @@ -58,7 +58,7 @@ module mpifx_scatterv_module !! allocate(send1(0)) !! end if !! - !! if (mycomm%master) then + !! if (mycomm%lead) then !! write(*, *) mycomm%rank, "Send1 buffer:", send1(:) !! end if !! call mpifx_scatterv(mycomm, send1, sendcounts, recv1) @@ -92,7 +92,7 @@ contains !! \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%masterrank) + !! \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) @@ -110,11 +110,11 @@ contains #:set SIZE = 'size(recv)' #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) - @:ASSERT(.not. mycomm%master .or. size(send) == size(recv) * mycomm%size) - @:ASSERT(.not. mycomm%master& + @: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%masterrank, root0, root) + call getoptarg(mycomm%leadrank, root0, root) if (mycomm%rank == root0) then if (present(displs)) then @:ASSERT(size(displs) == mycomm%size) @@ -150,7 +150,7 @@ contains !! \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%masterrank) + !! \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) @@ -168,13 +168,13 @@ contains #:set SIZE = '1' if RANK == 1 else 'size(recv)' #:set COUNT = ('len(recv) * ' + SIZE if HASLENGTH else SIZE) - @:ASSERT(.not. mycomm%master .or. size(send) == ${SIZE}$ * mycomm%size) - @:ASSERT(.not. mycomm%master .or. size(send, dim=${RANK}$) == mycomm%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%master .or. len(send) == len(recv)) + @:ASSERT(.not. mycomm%lead .or. len(send) == len(recv)) #:endif - call getoptarg(mycomm%masterrank, root0, root) + call getoptarg(mycomm%leadrank, root0, root) if (mycomm%rank == root0) then if (present(displs)) then @:ASSERT(size(displs) == mycomm%size) diff --git a/lib/mpifx_send.fpp b/lib/mpifx_send.fpp index 32c8f46..fc775dd 100644 --- a/lib/mpifx_send.fpp +++ b/lib/mpifx_send.fpp @@ -33,11 +33,11 @@ module mpifx_send_module !! !! call mpifx_init() !! call mycomm%init() - !! if (.not. mycomm%master) then + !! if (.not. mycomm%lead) then !! write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" - !! call mpifx_send(mycomm, msg, mycomm%masterrank) + !! call mpifx_send(mycomm, msg, mycomm%leadrank) !! else - !! write(*, "(A)") "Master node:" + !! write(*, "(A)") "Lead node:" !! do source = 1, mycomm%size - 1 !! call mpifx_recv(mycomm, msg, source) !! write(*,"(A,A)") "Message received: ", trim(msg) diff --git a/test/test_bcast.f90 b/test/test_bcast.f90 index b83a894..d4e5ba0 100644 --- a/test/test_bcast.f90 +++ b/test/test_bcast.f90 @@ -17,7 +17,7 @@ program test_bcast call mycomm%init() buffer(:) = 0 print "(A,I2.2,A,3I5)", "CHK01:", mycomm%rank, ":", buffer - if (mycomm%master) then + if (mycomm%lead) then buffer(:) = [ 1, 2, 3 ] end if print "(A,I2.2,A,3I5)", "CHK02:", mycomm%rank, ":", buffer @@ -28,7 +28,7 @@ program test_bcast ! Logical vector lbuffer(:) = .false. print "(A,I2.2,A,3L5)", "CHK04:", mycomm%rank, ":", lbuffer - if (mycomm%master) then + if (mycomm%lead) then lbuffer(:) = [ .true., .false., .true. ] end if print "(A,I2.2,A,3L5)", "CHK05:", mycomm%rank, ":", lbuffer @@ -39,7 +39,7 @@ program test_bcast ! Real rank 2 array rbuffer(:,:) = 0.0_dp print "(A,I2.2,A,4F10.6)", "CHK07:", mycomm%rank, ":", rbuffer - if (mycomm%master) then + 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 @@ -50,7 +50,7 @@ program test_bcast ! Complex scalar cbuffer = cmplx(0, 0, sp) print "(A,I2.2,A,2F10.6)", "CHK10:", mycomm%rank, ":", cbuffer - if (mycomm%master) then + if (mycomm%lead) then cbuffer = cmplx(-1, 1, sp) end if print "(A,I2.2,A,2F10.6)", "CHK11:", mycomm%rank, ":", cbuffer @@ -60,7 +60,7 @@ program test_bcast ! Character text = " " print "(A,I2.2,A,A6)", "CHK13:", mycomm%rank, ":", text - if (mycomm%master) then + if (mycomm%lead) then text = "hello" end if print "(A,I2.2,A,A6)", "CHK14:", mycomm%rank, ":", text diff --git a/test/test_gather.f90 b/test/test_gather.f90 index bbd0630..4badc84 100644 --- a/test/test_gather.f90 +++ b/test/test_gather.f90 @@ -14,7 +14,7 @@ program test_gather ! I0 -> I1 send0 = mycomm%rank * 2 ! Arbitrary number to send - if (mycomm%master) then + if (mycomm%lead) then allocate(recv1(1 * mycomm%size)) recv1(:) = 0 else @@ -23,7 +23,7 @@ program test_gather write(*, label // ",A,1X,I0)") 1, mycomm%rank, & & "Send0 buffer:", send0 call mpifx_gather(mycomm, send0, recv1) - if (mycomm%master) then + if (mycomm%lead) then write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" write(*, label // formstr) 2, mycomm%rank, & & "Recv1 buffer:", recv1(:) @@ -32,7 +32,7 @@ program test_gather ! I1 -> I1 allocate(send1(2)) - if (mycomm%master) then + if (mycomm%lead) then allocate(recv1(size(send1) * mycomm%size)) recv1(:) = 0 else @@ -43,14 +43,14 @@ program test_gather write(*, label // formstr) 3, mycomm%rank, & & "Send1 buffer:", send1(:) call mpifx_gather(mycomm, send1, recv1) - if (mycomm%master) then + 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%master) then + if (mycomm%lead) then allocate(recv2(size(send1), mycomm%size)) recv2(:,:) = 0 else @@ -61,7 +61,7 @@ program test_gather write(*, label // formstr) 5, mycomm%rank, & & "Send1 buffer:", send1(:) call mpifx_gather(mycomm, send1, recv2) - if (mycomm%master) then + if (mycomm%lead) then write(formstr, "(A,I0,A)") "A,", size(recv2), "(1X,I0))" write(*, label // formstr) 6, mycomm%rank, & & "Recv2 buffer:", recv2 diff --git a/test/test_gatherv.f90 b/test/test_gatherv.f90 index 7c7318a..e681496 100644 --- a/test/test_gatherv.f90 +++ b/test/test_gatherv.f90 @@ -17,12 +17,12 @@ program test_gatherv call mycomm%init() ! R1 -> R1 - if (mycomm%master) then + 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%master) then + if (mycomm%lead) then ! recv1 size is 1+2+3+...+mycomm%size nrecv = mycomm%size*(mycomm%size+1)/2 allocate(recv1(nrecv)) @@ -34,20 +34,20 @@ program test_gatherv allocate(recv1(0)) end if call mpifx_gatherv(mycomm, send1, recv1, recvcounts) - if (mycomm%master) then + if (mycomm%lead) then write(*, *) "Recv1 buffer:", recv1 deallocate(recvcounts) end if deallocate(recv1) ! R2 -> R2 - if (mycomm%master) then + 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%master) then + if (mycomm%lead) then ! recv1 size is 1+2+3+...+mycomm%size nrecv = mycomm%size*(mycomm%size+1)/2 allocate(recv2(10, nrecv)) @@ -60,19 +60,19 @@ program test_gatherv allocate(recv2(0,0)) end if call mpifx_gatherv(mycomm, send2, recv2, recvcounts) - if (mycomm%master) then + if (mycomm%lead) then write(*, *) "Recv2 buffer:", recv2(:,:) deallocate(recvcounts) end if deallocate(recv2) ! R0 -> R1 with specified receive pattern - if (mycomm%master) then + if (mycomm%lead) then write(*, *) write(*, *) 'Test gather scalar -> rank=1' end if send0 = real(mycomm%rank + 1, sp) - if (mycomm%master) then + if (mycomm%lead) then nrecv = mycomm%size allocate(recv1(nrecv)) allocate(recvcounts(mycomm%size)) @@ -86,7 +86,7 @@ program test_gatherv allocate(recv1(0)) end if call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%master) then + if (mycomm%lead) then write(*, *) "Recv1 buffer:", recv1 deallocate(recvcounts) deallocate(displs) @@ -94,12 +94,12 @@ program test_gatherv deallocate(recv1) ! R0 -> R1 with specified receive pattern including gaps - if (mycomm%master) then + if (mycomm%lead) then write(*, *) write(*, *) 'Test gather scalar -> rank=1' end if send0 = real(mycomm%rank + 1, sp) - if (mycomm%master) then + if (mycomm%lead) then nrecv = mycomm%size allocate(recv1(2*nrecv)) allocate(recvcounts(mycomm%size)) @@ -115,7 +115,7 @@ program test_gatherv allocate(recv1(0)) end if call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%master) then + if (mycomm%lead) then write(*, *) "Recv1 buffer:", recv1 deallocate(recvcounts) deallocate(displs) diff --git a/test/test_scatter.f90 b/test/test_scatter.f90 index 8bcf63f..7bbbad3 100644 --- a/test/test_scatter.f90 +++ b/test/test_scatter.f90 @@ -14,7 +14,7 @@ program test_scatter call mycomm%init() ! I1 -> I0 - if (mycomm%master) then + if (mycomm%lead) then allocate(send1(mycomm%size)) send1(:) = [ (ii, ii = 1, size(send1)) ] write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" @@ -30,7 +30,7 @@ program test_scatter & "Recv0 buffer:", recv0 ! I1 -> I1 - if (mycomm%master) then + if (mycomm%lead) then deallocate(send1) allocate(send1(2 * mycomm%size)) send1(:) = [ (ii, ii = 1, size(send1)) ] @@ -46,7 +46,7 @@ program test_scatter & "Recv1 buffer:", recv1 ! I2 -> I1 - if (mycomm%master) then + 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))" diff --git a/test/test_scatterv.f90 b/test/test_scatterv.f90 index 53b08c8..6de8d51 100644 --- a/test/test_scatterv.f90 +++ b/test/test_scatterv.f90 @@ -14,7 +14,7 @@ program test_scatterv call mycomm%init() ! I1 -> I0 - if (mycomm%master) then + if (mycomm%lead) then allocate(send1(mycomm%size)) allocate(sendcount(mycomm%size)) send1(:) = [ (ii, ii = 1, size(send1)) ] @@ -31,7 +31,7 @@ program test_scatterv write(*, label // formstr) 2, mycomm%rank, "Recv0 buffer:", recv0 ! I1 -> I1 - if (mycomm%master) then + if (mycomm%lead) then deallocate(send1) allocate(send1(2 * mycomm%size)) sendcount(:) = 2 @@ -46,7 +46,7 @@ program test_scatterv write(*, label // formstr) 4, mycomm%rank, "Recv1 buffer:", recv1 ! I2 -> I1 - if (mycomm%master) then + if (mycomm%lead) then allocate(send2(2, mycomm%size)) sendcount(:) = 2 send2(:,:) = reshape(send1, [ 2, mycomm%size ]) @@ -63,7 +63,7 @@ program test_scatterv & "Recv1 buffer:", recv1 ! I1 -> I1 - if (mycomm%master) then + if (mycomm%lead) then deallocate(send1) allocate(send1(2 * mycomm%size)) send1(:) = [ (ii, ii = 1, size(send1)) ] diff --git a/test/test_send_recv.f90 b/test/test_send_recv.f90 index d86711b..ae228a1 100644 --- a/test/test_send_recv.f90 +++ b/test/test_send_recv.f90 @@ -8,11 +8,11 @@ program test_send_recv call mpifx_init() call mycomm%init() - if (.not. mycomm%master) then + if (.not. mycomm%lead) then write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" - call mpifx_send(mycomm, msg, mycomm%masterrank) + call mpifx_send(mycomm, msg, mycomm%leadrank) else - write(*, "(A)") "Master node:" + write(*, "(A)") "Lead node:" do source = 1, mycomm%size - 1 call mpifx_recv(mycomm, msg, source) write(*,"(A,A)") "Message received: ", trim(msg) From fe60bcf9b31987190bdb1b38138c151440ec6946 Mon Sep 17 00:00:00 2001 From: Ben Hourahine Date: Mon, 15 Jun 2020 22:27:01 +0100 Subject: [PATCH 66/72] Comments from review --- external/fypp/README.rst | 2 +- lib/mpifx_comm.fpp | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/external/fypp/README.rst b/external/fypp/README.rst index 44bfd28..3d122fa 100644 --- a/external/fypp/README.rst +++ b/external/fypp/README.rst @@ -199,7 +199,7 @@ repository:: git clone https://github.com/aradi/fypp.git -and check out the default main branch. +and check out the default branch. The command line tool is a single stand-alone script. You can run it directly from the source folder :: diff --git a/lib/mpifx_comm.fpp b/lib/mpifx_comm.fpp index eb3f5a1..fa99e76 100644 --- a/lib/mpifx_comm.fpp +++ b/lib/mpifx_comm.fpp @@ -12,8 +12,8 @@ module mpifx_comm_module 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). + 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 From 30dabc3500afa473314da4e3a692ea8923596c95 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Mon, 6 Jul 2020 11:09:26 +0200 Subject: [PATCH 67/72] Add Travis-CI build instructions --- .travis.yml | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..5c0674e --- /dev/null +++ b/.travis.yml @@ -0,0 +1,25 @@ +os: linux +dist: bionic + +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: + - mkdir -p _build && pushd _build && cmake -DMAKE_BUILD_TYPE=Debug -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} .. && make -j From a24495ed495890430127b6e150a070ed3798ec62 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Mon, 6 Jul 2020 11:22:21 +0200 Subject: [PATCH 68/72] Fix CMake keyword --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 5c0674e..af4131f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,4 +22,4 @@ install: - pip install fypp script: - - mkdir -p _build && pushd _build && cmake -DMAKE_BUILD_TYPE=Debug -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} .. && make -j + - mkdir -p _build && pushd _build && cmake -DCMAKE_BUILD_TYPE=Debug -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} .. && make -j From 3e660492843c30c2ff1a0cde060a2f7fecec9ba0 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Mon, 6 Jul 2020 12:17:41 +0200 Subject: [PATCH 69/72] Also test install --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index af4131f..43d6332 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,4 +22,4 @@ install: - pip install fypp script: - - mkdir -p _build && pushd _build && cmake -DCMAKE_BUILD_TYPE=Debug -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} .. && make -j + - mkdir -p _build && pushd _build && cmake -DCMAKE_BUILD_TYPE=Debug -DCMAKE_INSTALL_PREFIX=$PWD/install -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} .. && make -j all install && popd From ddf3dbc6428f13294e1c61591241fcfedb384200 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 29 Sep 2020 21:58:56 +0200 Subject: [PATCH 70/72] Consolidate build framework - Target based CMake build - Dropped legacy make build framework - Export file for CMake based build (exports MpiFx::MpiFx) - Export file for Pkg-Conf base builds - Preprocessor fypp is an external dependency now --- .travis.yml | 25 +- CMakeLists.txt | 79 +- LICENSE | 2 +- README.rst | 105 +- cmake/MpiFxUtils.cmake | 58 + config.cmake | 37 + doc/doxygen/fyppf90.sh | 3 +- external/fypp/LICENSE.txt | 24 - external/fypp/README.rst | 232 -- external/fypp/fypp | 3020 ----------------- lib/CMakeLists.txt | 34 +- lib/make.build | 47 - lib/make.deps | 87 - make.arch.template | 24 - makefile | 32 - test/CMakeLists.txt | 2 +- test/integration/cmake/CMakeLists.txt | 8 + test/integration/cmake/runtest.sh | 26 + test/integration/cmake/test_mpifxbuild.f90 | 5 + test/integration/pkgconfig/runtest.sh | 45 + .../integration/pkgconfig/test_mpifxbuild.f90 | 72 + test/make.build | 77 - test/make.deps | 35 - utils/cr_makedep | 394 --- utils/export/mpifx-config.cmake.in | 10 + utils/export/mpifx.pc.in | 9 + 26 files changed, 426 insertions(+), 4066 deletions(-) create mode 100644 cmake/MpiFxUtils.cmake create mode 100644 config.cmake delete mode 100644 external/fypp/LICENSE.txt delete mode 100644 external/fypp/README.rst delete mode 100755 external/fypp/fypp delete mode 100644 lib/make.build delete mode 100644 lib/make.deps delete mode 100644 make.arch.template delete mode 100644 makefile create mode 100644 test/integration/cmake/CMakeLists.txt create mode 100755 test/integration/cmake/runtest.sh create mode 100644 test/integration/cmake/test_mpifxbuild.f90 create mode 100755 test/integration/pkgconfig/runtest.sh create mode 100644 test/integration/pkgconfig/test_mpifxbuild.f90 delete mode 100644 test/make.build delete mode 100644 test/make.deps delete mode 100755 utils/cr_makedep create mode 100644 utils/export/mpifx-config.cmake.in create mode 100644 utils/export/mpifx.pc.in diff --git a/.travis.yml b/.travis.yml index 43d6332..ba17c87 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,17 +1,16 @@ os: linux -dist: bionic +dist: focal language: python python: 3.7 - env: - - BUILD_SHARED_LIBS=false - - BUILD_SHARED_LIBS=true + - BUILD_SHARED_LIBS=False + - BUILD_SHARED_LIBS=True addons: - apt: - packages: + apt: + packages: - cmake - gfortran - libblas-dev @@ -19,7 +18,17 @@ addons: - libopenmpi-dev install: - - pip install fypp + - pip install fypp script: - - mkdir -p _build && pushd _build && cmake -DCMAKE_BUILD_TYPE=Debug -DCMAKE_INSTALL_PREFIX=$PWD/install -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} .. && make -j all install && popd + - > + FC=gfortran cmake -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} -B _build . + && cmake --build _build -- -j + && cmake --install _build + - > + CMAKE_PREFIX_PATH="${PWD}/_build/install:${CMAKE_PREFIX_PATH}" + ./test/integration/cmake/runtest.sh _build_cmake + - > + PKG_CONFIG_PATH="${PWD}/_build/install/lib/pkgconfig:${PKG_CONFIG_PATH}" + FC=mpifort + ./test/integration/pkgconfig/runtest.sh _build_pkgconfig diff --git a/CMakeLists.txt b/CMakeLists.txt index 7cb8a1c..44a313d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,39 +1,64 @@ -cmake_minimum_required(VERSION 3.5) +cmake_minimum_required(VERSION 3.16) -project(mpifx VERSION 0.1 LANGUAGES Fortran) +set(CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/config.cmake) -set(LIBRARY_ONLY FALSE CACHE BOOL "Whether only library should be compiled") +project(MpiFx VERSION 0.1 LANGUAGES Fortran) -option(BUILD_SHARED_LIBS "Whether the library should be a shared one" FALSE) +include(MpiFxUtils) +setup_build_type() -option(INSTALL_INCLUDE_FILES "Whether include / module files should be installed" TRUE) +# +# Prerequisites +# +find_package(MPI REQUIRED) +find_program(FYPP fypp) +if(NOT FYPP) + message(FATAL_ERROR "Preprocessor fypp could not be found") +endif() -# Installation paths -set(INSTALL_BIN_DIR "${CMAKE_INSTALL_PREFIX}/bin" CACHE PATH - "Installation directory for executables") +# +# Build instructions +# +add_subdirectory(lib) +if(NOT BUILD_EXPORTED_TARGETS_ONLY) + add_subdirectory(test) +endif() -set(INSTALL_LIB_DIR "${CMAKE_INSTALL_PREFIX}/lib" CACHE PATH - "Installation directory for libraries") +# +# Installation +# +add_library(MpiFx INTERFACE) +target_link_libraries(MpiFx INTERFACE mpifx) +install(TARGETS MpiFx EXPORT mpifx-targets) -set(INSTALL_MOD_DIR "${CMAKE_INSTALL_PREFIX}/include" CACHE PATH - "Installation directory for Fortran module files") +install(EXPORT mpifx-targets + FILE mpifx-targets.cmake + NAMESPACE MpiFx:: + DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/mpifx") -set(INSTALL_CMAKE_DIR "${CMAKE_INSTALL_PREFIX}/lib/cmake" CACHE PATH - "Installation directory for CMake package export files") +include(CMakePackageConfigHelpers) +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) -option(BUILD_SHARED_LIBS "Whether the library should be shared" FALSE) +write_basic_package_version_file( + ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY SameMajorVersion) -option(INSTALL_INCLUDE_FILES "Whether include and module files should be installed" TRUE) +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) -find_package(MPI REQUIRED) -find_program(FYPP fypp) -if(FYPP) - message(STATUS "Preprocessor fypp: ${FYPP}") -else() - message(FATAL_ERROR "Prepropcessor fypp not found") -endif() +include(GNUInstallDirs) +GNUInstallDirs_get_absolute_install_dir(CMAKE_INSTALL_FULL_MODULEDIR CMAKE_INSTALL_MODULEDIR) -add_subdirectory(lib) -if(NOT LIBRARY_ONLY) - add_subdirectory(test) -endif() +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 ae5d9b4..e33defa 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (C) 2018 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 b26337e..484d74e 100644 --- a/README.rst +++ b/README.rst @@ -1,55 +1,94 @@ **************************************** -MPIFX - Modern Fortran Interface for MPI +MpiFx - Modern Fortran Interface for MPI **************************************** -The open source library `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. The -documentation is included inside the repository, but is also available at +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. + +The documentation is included inside the repository, but is also available at `dftbplus.github.io `_. -It currently contains only a few routines so far, but if those happen to be the -ones you need, feel free to use this project. MPIFX is licensed under the -**simplified BSD license**. -If your desired MPI routine is not yet wrapped up, feel free to contribute to -the project to include the target functionality. +Installation +============ +Prerequisites +------------- -INSTALL -======= +* 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:: -Stand-alone building --------------------- + FC=gfortran cmake -B _build + cmake --build _build + cmake --install _build -#. Make a copy of the file `make.arch.template` as `make.arch`:: +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.:: - cp make.arch.template make.arch + FC=ifort cmake -B _build -DBUILD_LIBRARY_ONLY=True + -#. Configure any settings in `make.arch` in order to adapt it to your - environment. +Testing +------- -#. Issue :: +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. - make - in order to build and library and :: +Using the library +================= - make install +CMake build +----------- - in order to install it. +* Make sure to add the root folder of the installed library to the + ``CMAKE_PREFIX_PATH`` environment variable. -#. You may build the examples in the `test/` subfolder with :: +* Use ``find_package()`` in `CMakeLists.txt` to locate the library and link + ``MpiFx::MpiFx`` to every target which relies directly on the library :: - make test + 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) - -Build the library as part of a build process --------------------------------------------- +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 +======= -You may build the library on-the-fly during the build of your program. Invoke -the library makefile `lib/make.build` during your build process from the folder -where you wish to build the library. Make sure to pass the necessary -make-variables (as documented in the library makfile). See the `makefile` in -this folder for an example how to invoke the library makefile. +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..7fa02b3 --- /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_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..28d2389 --- /dev/null +++ b/config.cmake @@ -0,0 +1,37 @@ +# +# 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(CMAKE_INSTALL_LIBDIR "lib" CACHE PATH "Installation directory for libraries") + +set(CMAKE_INSTALL_INCLUDEDIR "include/mpifx" CACHE PATH + "Installation directory for header and include files") + +set(CMAKE_INSTALL_MODULEDIR "${CMAKE_INSTALL_INCLUDEDIR}/modfiles" CACHE PATH + "Installation directory for Fortran module files") diff --git a/doc/doxygen/fyppf90.sh b/doc/doxygen/fyppf90.sh index 3fe0ab2..405b459 100755 --- a/doc/doxygen/fyppf90.sh +++ b/doc/doxygen/fyppf90.sh @@ -1,4 +1,3 @@ #!/bin/bash srcdir=$(dirname $1) -fyppdir=$srcdir/../external/fypp -$fyppdir/fypp -I$(dirname $1) $1 +fypp -I$(dirname $1) $1 diff --git a/external/fypp/LICENSE.txt b/external/fypp/LICENSE.txt deleted file mode 100644 index a6a775c..0000000 --- a/external/fypp/LICENSE.txt +++ /dev/null @@ -1,24 +0,0 @@ -Copyright (c) 2016-2020 Bálint Aradi, Universität Bremen - -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. - -2. 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/external/fypp/README.rst b/external/fypp/README.rst deleted file mode 100644 index 3d122fa..0000000 --- a/external/fypp/README.rst +++ /dev/null @@ -1,232 +0,0 @@ -********************************************* -Fypp — Python powered Fortran metaprogramming -********************************************* - -.. image:: https://travis-ci.org/aradi/fypp.svg?branch=develop - :target: https://travis-ci.org/aradi/fypp - -Fypp is a Python powered preprocessor. It can be used for any programming -languages but its primary aim is to offer a Fortran preprocessor, which helps to -extend Fortran with condititional compiling and template metaprogramming -capabilities. Instead of introducing its own expression syntax, it uses Python -expressions in its preprocessor directives, offering the consistency and -versatility of Python when formulating metaprogramming tasks. It puts strong -emphasis on robustness and on neat integration into developing toolchains. - -The project is `hosted on github `_. - -`Detailed DOCUMENTATION `_ is available on -`readthedocs.org `_. - -Fypp is released under the *BSD 2-clause license*. - - -Main features -============= - -* Definition, evaluation and removal of variables:: - - #:if DEBUG > 0 - print *, "Some debug information" - #:endif - - #:set LOGLEVEL = 2 - print *, "LOGLEVEL: ${LOGLEVEL}$" - - #:del LOGLEVEL - -* Macro definitions and macro calls:: - - #:def ASSERT(cond) - #:if DEBUG > 0 - if (.not. ${cond}$) then - print *, "Assert failed in file ${_FILE_}$, line ${_LINE_}$" - error stop - end if - #:endif - #:enddef ASSERT - - ! Invoked via direct call (argument needs no quotation) - @:ASSERT(size(myArray) > 0) - - ! Invoked as Python expression (argument needs quotation) - $:ASSERT('size(myArray) > 0') - -* Conditional output:: - - program test - #:if defined('WITH_MPI') - use mpi - #:elif defined('WITH_OPENMP') - use openmp - #:else - use serial - #:endif - -* Iterated output (e.g. for generating Fortran templates):: - - interface myfunc - #:for dtype in ['real', 'dreal', 'complex', 'dcomplex'] - module procedure myfunc_${dtype}$ - #:endfor - end interface myfunc - -* Inline directives:: - - logical, parameter :: hasMpi = #{if defined('MPI')}# .true. #{else}# .false. #{endif}# - -* Insertion of arbitrary Python expressions:: - - character(*), parameter :: comp_date = "${time.strftime('%Y-%m-%d')}$" - -* Inclusion of files during preprocessing:: - - #:include "macrodefs.fypp" - -* Using Fortran-style continutation lines in preprocessor directives:: - - #:if var1 > var2 & - & or var2 > var4 - print *, "Doing something here" - #:endif - -* Passing (unquoted) multiline string arguments to callables:: - - #! Callable needs only string argument - #:def DEBUG_CODE(code) - #:if DEBUG > 0 - $:code - #:endif - #:enddef DEBUG_CODE - - #! Pass code block as first positional argument - #:block DEBUG_CODE - if (size(array) > 100) then - print *, "DEBUG: spuriously large array" - end if - #:endblock DEBUG_CODE - - #! Callable needs also non-string argument types - #:def REPEAT_CODE(code, repeat) - #:for ind in range(repeat) - $:code - #:endfor - #:enddef REPEAT_CODE - - #! Pass code block as positional argument and 3 as keyword argument "repeat" - #:block REPEAT_CODE(repeat=3) - this will be repeated 3 times - #:endblock REPEAT_CODE - -* Preprocessor comments:: - - #! This will not show up in the output - #! Also the newline characters at the end of the lines will be suppressed - -* Suppressing the preprocessor output in selected regions:: - - #! Definitions are read, but no output (e.g. newlines) will be produced - #:mute - #:include "macrodefs.fypp" - #:endmute - -* Explicit request for stopping the preprocessor:: - - #:if DEBUGLEVEL < 0 - #:stop 'Negative debug level not allowed!' - #:endif - -* Easy check for macro parameter sanity:: - - #:def mymacro(RANK) - #! Macro only works for RANK 1 and above - #:assert RANK > 0 - : - #:enddef mymacro - -* Line numbering directives in output:: - - program test - #:if defined('MPI') - use mpi - #:endif - : - - transformed to :: - - # 1 "test.fypp" 1 - program test - # 3 "test.fypp" - use mpi - # 5 "test.fypp" - : - - when variable ``MPI`` is defined and Fypp was instructed to generate line - markers. - -* Automatic folding of generated lines exceeding line length limit - - -Installing -========== - -Fypp needs a working Python interpreter. It is compatible with Python 2 (version -2.6 and above) and Python 3 (all versions). - -Automatic install ------------------ - -Use Pythons command line installer ``pip`` in order to download the stable -release from the `Fypp page on PyPI `_ and -install it on your system:: - - pip install fypp - -This installs both, the command line tool ``fypp`` and the Python module -``fypp.py``. Latter you can import if you want to access the functionality of -Fypp directly from within your Python scripts. - - -Manual install --------------- - -For a manual install, you can download the source code of the **stable** -releases from the `Fypp project website -`_. - -If you wish to obtain the latest **development** version, clone the projects -repository:: - - git clone https://github.com/aradi/fypp.git - -and check out the default branch. - -The command line tool is a single stand-alone script. You can run it directly -from the source folder :: - - FYPP_SOURCE_FOLDER/bin/fypp - -or after copying it from the `bin` folder to any location listed in your `PATH` -environment variable, by just issuing :: - - fypp - -The python module ``fypp.py`` can be found in ``FYP_SOURCE_FOLDER/src``. - - -Running -======= - -The Fypp command line tool reads a file, preprocesses it and writes it to -another file, so you would typically invoke it like:: - - fypp source.fpp source.f90 - -which would process `source.fpp` and write the result to `source.f90`. If -input and output files are not specified, information is read from stdin and -written to stdout. - -The behavior of Fypp can be influenced with various command line options. A -summary of all command line options can be obtained by:: - - fypp -h diff --git a/external/fypp/fypp b/external/fypp/fypp deleted file mode 100755 index 31e5e32..0000000 --- a/external/fypp/fypp +++ /dev/null @@ -1,3020 +0,0 @@ -#!/usr/bin/env python -# -*- coding: utf-8 -*- -################################################################################ -# -# fypp -- Python powered Fortran preprocessor -# -# Copyright (c) 2016-2020 Bálint Aradi, Universität Bremen -# -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are met: -# -# 1. Redistributions of source code must retain the above copyright notice, this -# list of conditions and the following disclaimer. -# -# 2. 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. -# -################################################################################ - -'''For using the functionality of the Fypp preprocessor from within -Python, one usually interacts with the following two classes: - -* `Fypp`_: The actual Fypp preprocessor. It returns for a given input - the preprocessed output. - -* `FyppOptions`_: Contains customizable settings controling the behaviour of - `Fypp`_. Alternatively, the function `get_option_parser()`_ can be used to - obtain an option parser, which can create settings based on command line - arguments. - -If processing stops prematurely, an instance of one of the following -subclasses of `FyppError`_ is raised: - -* FyppFatalError: Unexpected error (e.g. bad input, missing files, etc.) - -* FyppStopRequest: Stop was triggered by an explicit request in the input - (by a stop- or an assert-directive). -''' - -from __future__ import print_function -import sys -import types -import inspect -import re -import os -import errno -import time -import optparse -import io -if sys.version_info[0] >= 3: - import builtins -else: - import __builtin__ as builtins - -# Prevent cluttering user directory with Python bytecode -sys.dont_write_bytecode = True - -VERSION = '3.0' - -STDIN = '' - -FILEOBJ = '' - -STRING = '' - -ERROR_EXIT_CODE = 1 - -USER_ERROR_EXIT_CODE = 2 - -_ALL_DIRECTIVES_PATTERN = r''' -# comment block -(?:^[ \t]*\#!.*\n)+ -| -# line directive (with optional continuation lines) -^[ \t]*(?P[\#\$@]):[ \t]* -(?P.+?(?:&[ \t]*\n(?:[ \t]*&)?.*?)*)?[ \t]*\n -| -# inline eval directive -(?P[$\#@])\{[ \t]*(?P.+?)?[ \t]*\}(?P=idirtype) -''' - -_ALL_DIRECTIVES_REGEXP = re.compile( - _ALL_DIRECTIVES_PATTERN, re.VERBOSE | re.MULTILINE) - -_CONTROL_DIR_REGEXP = re.compile( - r'(?P[a-zA-Z_]\w*)[ \t]*(?:[ \t]+(?P[^ \t].*))?$') - -_DIRECT_CALL_REGEXP = re.compile( - r'(?P[a-zA-Z_][\w.]*)[ \t]*\((?P.+?)?\)$') - -_DIRECT_CALL_KWARG_REGEXP = re.compile( - r'(?:(?P[a-zA-Z_]\w*)\s*=(?=[^=]|$))?') - -_DEF_PARAM_REGEXP = re.compile( - r'^(?P[a-zA-Z_]\w*)[ \t]*\(\s*(?P.+)?\s*\)$') - -_SIMPLE_CALLABLE_REGEXP = re.compile( - r'^(?P[a-zA-Z_][\w.]*)[ \t]*(?:\([ \t]*(?P.*)[ \t]*\))?$') - -_IDENTIFIER_NAME_REGEXP = re.compile(r'^(?P[a-zA-Z_]\w*)$') - -_PREFIXED_IDENTIFIER_NAME_REGEXP = re.compile(r'^(?P[a-zA-Z_][\w.]*)$') - -_SET_PARAM_REGEXP = re.compile( - r'^(?P(?:[(]\s*)?[a-zA-Z_]\w*(?:\s*,\s*[a-zA-Z_]\w*)*(?:\s*[)])?)\s*'\ - r'(?:=\s*(?P.*))?$') - -_DEL_PARAM_REGEXP = re.compile( - r'^(?:[(]\s*)?[a-zA-Z_]\w*(?:\s*,\s*[a-zA-Z_]\w*)*(?:\s*[)])?$') - -_FOR_PARAM_REGEXP = re.compile( - r'^(?P[a-zA-Z_]\w*(\s*,\s*[a-zA-Z_]\w*)*)\s+in\s+(?P.+)$') - -_INCLUDE_PARAM_REGEXP = re.compile(r'^(\'|")(?P.*?)\1$') - -_COMMENTLINE_REGEXP = re.compile(r'^[ \t]*!.*$') - -_CONTLINE_REGEXP = re.compile(r'&[ \t]*\n(?:[ \t]*&)?') - -_UNESCAPE_TEXT_REGEXP1 = re.compile(r'([$#@])\\(\\*)([{:])') - -_UNESCAPE_TEXT_REGEXP2 = re.compile(r'#\\(\\*)([!])') - -_UNESCAPE_TEXT_REGEXP3 = re.compile(r'(\})\\(\\*)([$#@])') - -_INLINE_EVAL_REGION_REGEXP = re.compile(r'\${.*?}\$') - -_RESERVED_PREFIX = '__' - -_RESERVED_NAMES = set(['defined', 'setvar', 'getvar', 'delvar', 'globalvar', - '_LINE_', '_FILE_', '_THIS_FILE_', '_THIS_LINE_', - '_TIME_', '_DATE_']) - -_LINENUM_NEW_FILE = 1 - -_LINENUM_RETURN_TO_FILE = 2 - -_QUOTES_FORTRAN = '\'"' - -_OPENING_BRACKETS_FORTRAN = '{([' - -_CLOSING_BRACKETS_FORTRAN = '})]' - -_ARGUMENT_SPLIT_CHAR_FORTRAN = ',' - - -class FyppError(Exception): - '''Signalizes error occuring during preprocessing. - - Args: - msg (str): Error message. - fname (str): File name. None (default) if file name is not available. - span (tuple of int): Beginning and end line of the region where error - occured or None if not available. If fname was not None, span must - not be None. - cause (Exception): Contains the exception, which triggered this - exception or None, if this exception is not masking any underlying - one. (Emulates Python 3 exception chaining in a Python 2 compatible - way.) - - Attributes: - msg (str): Error message. - fname (str or None): File name or None if not available. - span (tuple of int or None): Beginning and end line of the region - where error occured or None if not available. Line numbers start - from zero. For directives, which do not consume end of the line, - start and end lines are identical. - cause (Exception): In case this exception is raised in an except block, - the original exception should be passed here. (Emulates Python 3 - exception chaining in a Python 2 compatible way.) - ''' - - def __init__(self, msg, fname=None, span=None, cause=None): - super(FyppError, self).__init__() - self.msg = msg - self.fname = fname - self.span = span - self.cause = cause - - - def __str__(self): - msg = [self.__class__.__name__, ': '] - if self.fname is not None: - msg.append("file '" + self.fname + "'") - if self.span[1] > self.span[0] + 1: - msg.append(', lines {0}-{1}'.format( - self.span[0] + 1, self.span[1])) - else: - msg.append(', line {0}'.format(self.span[0] + 1)) - msg.append('\n') - if self.msg: - msg.append(self.msg) - if self.cause is not None: - msg.append('\n' + str(self.cause)) - return ''.join(msg) - - -class FyppFatalError(FyppError): - '''Signalizes an unexpected error during processing.''' - - -class FyppStopRequest(FyppError): - '''Signalizes an explicitely triggered stop (e.g. via stop directive)''' - - -class Parser: - '''Parses a text and generates events when encountering Fypp constructs. - - Args: - includedirs (list): List of directories, in which include files should - be searched for, when they are not found at the default location. - - encoding (str): Encoding to use when reading the file (default: utf-8) - ''' - - def __init__(self, includedirs=None, encoding='utf-8'): - - # Directories to search for include files - if includedirs is None: - self._includedirs = [] - else: - self._includedirs = includedirs - - # Encoding - self._encoding = encoding - - # Name of current file - self._curfile = None - - # Directory of current file - self._curdir = None - - - def parsefile(self, fobj): - '''Parses file or a file like object. - - Args: - fobj (str or file): Name of a file or a file like object. - ''' - if isinstance(fobj, str): - if fobj == STDIN: - self._includefile(None, sys.stdin, STDIN, os.getcwd()) - else: - inpfp = _open_input_file(fobj, self._encoding) - self._includefile(None, inpfp, fobj, os.path.dirname(fobj)) - inpfp.close() - else: - self._includefile(None, fobj, FILEOBJ, os.getcwd()) - - - def _includefile(self, span, fobj, fname, curdir): - oldfile = self._curfile - olddir = self._curdir - self._curfile = fname - self._curdir = curdir - self._parse_txt(span, fname, fobj.read()) - self._curfile = oldfile - self._curdir = olddir - - - def parse(self, txt): - '''Parses string. - - Args: - txt (str): Text to parse. - ''' - self._curfile = STRING - self._curdir = '' - self._parse_txt(None, self._curfile, txt) - - - def handle_include(self, span, fname): - '''Called when parser starts to process a new file. - - It is a dummy methond and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the include directive - or None if called the first time for the main input. - fname (str): Name of the file. - ''' - self._log_event('include', span, filename=fname) - - - def handle_endinclude(self, span, fname): - '''Called when parser finished processing a file. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the include directive - or None if called the first time for the main input. - fname (str): Name of the file. - ''' - self._log_event('endinclude', span, filename=fname) - - - def handle_set(self, span, name, expr): - '''Called when parser encounters a set directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the variable. - expr (str): String representation of the expression to be assigned - to the variable. - ''' - self._log_event('set', span, name=name, expression=expr) - - - def handle_def(self, span, name, args): - '''Called when parser encounters a def directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the macro to be defined. - argexpr (str): String with argument definition (or None) - ''' - self._log_event('def', span, name=name, arguments=args) - - - def handle_enddef(self, span, name): - '''Called when parser encounters an enddef directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name found after the enddef directive. - ''' - self._log_event('enddef', span, name=name) - - - def handle_del(self, span, name): - '''Called when parser encounters a del directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the variable to delete. - ''' - self._log_event('del', span, name=name) - - - def handle_if(self, span, cond): - '''Called when parser encounters an if directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - cond (str): String representation of the branching condition. - ''' - self._log_event('if', span, condition=cond) - - - def handle_elif(self, span, cond): - '''Called when parser encounters an elif directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - cond (str): String representation of the branching condition. - ''' - self._log_event('elif', span, condition=cond) - - - def handle_else(self, span): - '''Called when parser encounters an else directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('else', span) - - - def handle_endif(self, span): - '''Called when parser encounters an endif directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('endif', span) - - - def handle_for(self, span, varexpr, iterator): - '''Called when parser encounters a for directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - varexpr (str): String representation of the loop variable - expression. - iterator (str): String representation of the iterable. - ''' - self._log_event('for', span, variable=varexpr, iterable=iterator) - - - def handle_endfor(self, span): - '''Called when parser encounters an endfor directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('endfor', span) - - - def handle_call(self, span, name, argexpr, blockcall): - '''Called when parser encounters a call directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the callable to call - argexpr (str or None): Argument expression containing additional - arguments for the call. - blockcall (bool): Whether the alternative "block / contains / - endblock" calling directive has been used. - ''' - self._log_event('call', span, name=name, argexpr=argexpr, - blockcall=blockcall) - - - def handle_nextarg(self, span, name, blockcall): - '''Called when parser encounters a nextarg directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str or None): Name of the argument following next or - None if it should be the next positional argument. - blockcall (bool): Whether the alternative "block / contains / - endblock" calling directive has been used. - ''' - self._log_event('nextarg', span, name=name, blockcall=blockcall) - - - def handle_endcall(self, span, name, blockcall): - '''Called when parser encounters an endcall directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name found after the endcall directive. - blockcall (bool): Whether the alternative "block / contains / - endblock" calling directive has been used. - ''' - self._log_event('endcall', span, name=name, blockcall=blockcall) - - - def handle_eval(self, span, expr): - '''Called when parser encounters an eval directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - expr (str): String representation of the Python expression to - be evaluated. - ''' - self._log_event('eval', span, expression=expr) - - - def handle_global(self, span, name): - '''Called when parser encounters a global directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the variable which should be made global. - ''' - self._log_event('global', span, name=name) - - - def handle_text(self, span, txt): - '''Called when parser finds text which must left unaltered. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - txt (str): Text. - ''' - self._log_event('text', span, content=txt) - - - def handle_comment(self, span): - '''Called when parser finds a preprocessor comment. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('comment', span) - - - def handle_mute(self, span): - '''Called when parser finds a mute directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('mute', span) - - - def handle_endmute(self, span): - '''Called when parser finds an endmute directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('endmute', span) - - - def handle_stop(self, span, msg): - '''Called when parser finds an stop directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - msg (str): Stop message. - ''' - self._log_event('stop', span, msg=msg) - - - def handle_assert(self, span): - '''Called when parser finds an assert directive. - - It is a dummy method and should be overriden for actual use. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._log_event('assert', span) - - - @staticmethod - def _log_event(event, span=(-1, -1), **params): - print('{0}: {1} --> {2}'.format(event, span[0], span[1])) - for parname, parvalue in params.items(): - print(' {0}: ->|{1}|<-'.format(parname, parvalue)) - print() - - - def _parse_txt(self, includespan, fname, txt): - self.handle_include(includespan, fname) - self._parse(txt) - self.handle_endinclude(includespan, fname) - - - def _parse(self, txt, linenr=0, directcall=False): - pos = 0 - for match in _ALL_DIRECTIVES_REGEXP.finditer(txt): - start, end = match.span() - if start > pos: - endlinenr = linenr + txt.count('\n', pos, start) - self._process_text(txt[pos:start], (linenr, endlinenr)) - linenr = endlinenr - endlinenr = linenr + txt.count('\n', start, end) - span = (linenr, endlinenr) - ldirtype, ldir, idirtype, idir = match.groups() - if directcall and (idirtype is None or idirtype != '$'): - msg = 'only inline eval directives allowed in direct calls' - raise FyppFatalError(msg, self._curfile, span) - elif idirtype is not None: - if idir is None: - msg = 'missing inline directive content' - raise FyppFatalError(msg, self._curfile, span) - dirtype = idirtype - content = idir - elif ldirtype is not None: - if ldir is None: - msg = 'missing line directive content' - raise FyppFatalError(msg, self._curfile, span) - dirtype = ldirtype - content = _CONTLINE_REGEXP.sub('', ldir) - else: - # Comment directive - dirtype = None - if dirtype == '$': - self.handle_eval(span, content) - elif dirtype == '#': - self._process_control_dir(content, span) - elif dirtype == '@': - self._process_direct_call(content, span) - else: - self.handle_comment(span) - pos = end - linenr = endlinenr - if pos < len(txt): - endlinenr = linenr + txt.count('\n', pos) - self._process_text(txt[pos:], (linenr, endlinenr)) - - - def _process_text(self, txt, span): - escaped_txt = self._unescape(txt) - self.handle_text(span, escaped_txt) - - - def _process_control_dir(self, content, span): - match = _CONTROL_DIR_REGEXP.match(content) - if not match: - msg = "invalid control directive content '{0}'".format(content) - raise FyppFatalError(msg, self._curfile, span) - directive, param = match.groups() - if directive == 'if': - self._check_param_presence(True, 'if', param, span) - self.handle_if(span, param) - elif directive == 'else': - self._check_param_presence(False, 'else', param, span) - self.handle_else(span) - elif directive == 'elif': - self._check_param_presence(True, 'elif', param, span) - self.handle_elif(span, param) - elif directive == 'endif': - self._check_param_presence(False, 'endif', param, span) - self.handle_endif(span) - elif directive == 'def': - self._check_param_presence(True, 'def', param, span) - self._check_not_inline_directive('def', span) - self._process_def(param, span) - elif directive == 'enddef': - self._process_enddef(param, span) - elif directive == 'set': - self._check_param_presence(True, 'set', param, span) - self._process_set(param, span) - elif directive == 'del': - self._check_param_presence(True, 'del', param, span) - self._process_del(param, span) - elif directive == 'for': - self._check_param_presence(True, 'for', param, span) - self._process_for(param, span) - elif directive == 'endfor': - self._check_param_presence(False, 'endfor', param, span) - self.handle_endfor(span) - elif directive == 'call' or directive == 'block': - self._check_param_presence(True, directive, param, span) - self._process_call(param, span, directive == 'block') - elif directive == 'nextarg' or directive == 'contains': - self._process_nextarg(param, span, directive == 'contains') - elif directive == 'endcall' or directive == 'endblock': - self._process_endcall(param, span, directive == 'endblock') - elif directive == 'include': - self._check_param_presence(True, 'include', param, span) - self._check_not_inline_directive('include', span) - self._process_include(param, span) - elif directive == 'mute': - self._check_param_presence(False, 'mute', param, span) - self._check_not_inline_directive('mute', span) - self.handle_mute(span) - elif directive == 'endmute': - self._check_param_presence(False, 'endmute', param, span) - self._check_not_inline_directive('endmute', span) - self.handle_endmute(span) - elif directive == 'stop': - self._check_param_presence(True, 'stop', param, span) - self._check_not_inline_directive('stop', span) - self.handle_stop(span, param) - elif directive == 'assert': - self._check_param_presence(True, 'assert', param, span) - self._check_not_inline_directive('assert', span) - self.handle_assert(span, param) - elif directive == 'global': - self._check_param_presence(True, 'global', param, span) - self._process_global(param, span) - else: - msg = "unknown directive '{0}'".format(directive) - raise FyppFatalError(msg, self._curfile, span) - - - def _process_direct_call(self, callexpr, span): - match = _DIRECT_CALL_REGEXP.match(callexpr) - if not match: - msg = "invalid direct call expression" - raise FyppFatalError(msg, self._curfile, span) - callname = match.group('callname') - self.handle_call(span, callname, None, False) - callparams = match.group('callparams') - if callparams is None or not callparams.strip(): - args = [] - else: - try: - args = [arg.strip() for arg in _argsplit_fortran(callparams)] - except Exception as exc: - msg = 'unable to parse direct call argument' - raise FyppFatalError(msg, self._curfile, span, exc) - for arg in args: - match = _DIRECT_CALL_KWARG_REGEXP.match(arg) - argval = arg[match.end():].strip() - # Remove enclosing braces if present - if argval.startswith('{'): - argval = argval[1:-1] - keyword = match.group('kwname') - self.handle_nextarg(span, keyword, False) - self._parse(argval, linenr=span[0], directcall=True) - self.handle_endcall(span, callname, False) - - - def _process_def(self, param, span): - match = _DEF_PARAM_REGEXP.match(param) - if not match: - msg = "invalid macro definition '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - name = match.group('name') - argexpr = match.group('args') - self.handle_def(span, name, argexpr) - - - def _process_enddef(self, param, span): - if param is not None: - match = _IDENTIFIER_NAME_REGEXP.match(param) - if not match: - msg = "invalid enddef parameter '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - param = match.group('name') - self.handle_enddef(span, param) - - - def _process_set(self, param, span): - match = _SET_PARAM_REGEXP.match(param) - if not match: - msg = "invalid variable assignment '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - self.handle_set(span, match.group('name'), match.group('expr')) - - - def _process_global(self, param, span): - match = _DEL_PARAM_REGEXP.match(param) - if not match: - msg = "invalid variable specification '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - self.handle_global(span, param) - - - def _process_del(self, param, span): - match = _DEL_PARAM_REGEXP.match(param) - if not match: - msg = "invalid variable specification '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - self.handle_del(span, param) - - - def _process_for(self, param, span): - match = _FOR_PARAM_REGEXP.match(param) - if not match: - msg = "invalid for loop declaration '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - loopexpr = match.group('loopexpr') - loopvars = [s.strip() for s in loopexpr.split(',')] - self.handle_for(span, loopvars, match.group('iter')) - - - def _process_call(self, param, span, blockcall): - match = _SIMPLE_CALLABLE_REGEXP.match(param) - if not match: - msg = "invalid callable expression '{}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - name, args = match.groups() - self.handle_call(span, name, args, blockcall) - - - def _process_nextarg(self, param, span, blockcall): - if param is not None: - match = _IDENTIFIER_NAME_REGEXP.match(param) - if not match: - msg = "invalid nextarg parameter '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - param = match.group('name') - self.handle_nextarg(span, param, blockcall) - - - def _process_endcall(self, param, span, blockcall): - if param is not None: - match = _PREFIXED_IDENTIFIER_NAME_REGEXP.match(param) - if not match: - msg = "invalid endcall parameter '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - param = match.group('name') - self.handle_endcall(span, param, blockcall) - - - def _process_include(self, param, span): - match = _INCLUDE_PARAM_REGEXP.match(param) - if not match: - msg = "invalid include file declaration '{0}'".format(param) - raise FyppFatalError(msg, self._curfile, span) - fname = match.group('fname') - for incdir in [self._curdir] + self._includedirs: - fpath = os.path.join(incdir, fname) - if os.path.exists(fpath): - break - else: - msg = "include file '{0}' not found".format(fname) - raise FyppFatalError(msg, self._curfile, span) - inpfp = _open_input_file(fpath, self._encoding) - self._includefile(span, inpfp, fpath, os.path.dirname(fpath)) - inpfp.close() - - - def _process_mute(self, span): - if span[0] == span[1]: - msg = 'Inline form of mute directive not allowed' - raise FyppFatalError(msg, self._curfile, span) - self.handle_mute(span) - - - def _process_endmute(self, span): - if span[0] == span[1]: - msg = 'Inline form of endmute directive not allowed' - raise FyppFatalError(msg, self._curfile, span) - self.handle_endmute(span) - - - def _check_param_presence(self, presence, directive, param, span): - if (param is not None) != presence: - if presence: - msg = 'missing data in {0} directive'.format(directive) - else: - msg = 'forbidden data in {0} directive'.format(directive) - raise FyppFatalError(msg, self._curfile, span) - - - def _check_not_inline_directive(self, directive, span): - if span[0] == span[1]: - msg = 'Inline form of {0} directive not allowed'.format(directive) - raise FyppFatalError(msg, self._curfile, span) - - - @staticmethod - def _unescape(txt): - txt = _UNESCAPE_TEXT_REGEXP1.sub(r'\1\2\3', txt) - txt = _UNESCAPE_TEXT_REGEXP2.sub(r'#\1\2', txt) - txt = _UNESCAPE_TEXT_REGEXP3.sub(r'\1\2\3', txt) - return txt - - -class Builder: - '''Builds a tree representing a text with preprocessor directives. - ''' - - def __init__(self): - # The tree, which should be built. - self._tree = [] - - # List of all open constructs - self._open_blocks = [] - - # Nodes to which the open blocks have to be appended when closed - self._path = [] - - # Nr. of open blocks when file was opened. Used for checking whether all - # blocks have been closed, when file processing finishes. - self._nr_prev_blocks = [] - - # Current node, to which content should be added - self._curnode = self._tree - - # Current file - self._curfile = None - - - def reset(self): - '''Resets the builder so that it starts to build a new tree.''' - self._tree = [] - self._open_blocks = [] - self._path = [] - self._nr_prev_blocks = [] - self._curnode = self._tree - self._curfile = None - - - def handle_include(self, span, fname): - '''Should be called to signalize change to new file. - - Args: - span (tuple of int): Start and end line of the include directive - or None if called the first time for the main input. - fname (str): Name of the file to be included. - ''' - self._path.append(self._curnode) - self._curnode = [] - self._open_blocks.append( - ('include', self._curfile, [span], fname, None)) - self._curfile = fname - self._nr_prev_blocks.append(len(self._open_blocks)) - - - def handle_endinclude(self, span, fname): - '''Should be called when processing of a file finished. - - Args: - span (tuple of int): Start and end line of the include directive - or None if called the first time for the main input. - fname (str): Name of the file which has been included. - ''' - nprev_blocks = self._nr_prev_blocks.pop(-1) - if len(self._open_blocks) > nprev_blocks: - directive, fname, spans = self._open_blocks[-1][0:3] - msg = '{0} directive still unclosed when reaching end of file'\ - .format(directive) - raise FyppFatalError(msg, self._curfile, spans[0]) - block = self._open_blocks.pop(-1) - directive, blockfname, spans = block[0:3] - if directive != 'include': - msg = 'internal error: last open block is not \'include\' when '\ - 'closing file \'{0}\''.format(fname) - raise FyppFatalError(msg) - if span != spans[0]: - msg = 'internal error: span for include and endinclude differ ('\ - '{0} vs {1}'.format(span, spans[0]) - raise FyppFatalError(msg) - oldfname, _ = block[3:5] - if fname != oldfname: - msg = 'internal error: mismatching file name in close_file event'\ - " (expected: '{0}', got: '{1}')".format(oldfname, fname) - raise FyppFatalError(msg, fname) - block = directive, blockfname, spans, fname, self._curnode - self._curnode = self._path.pop(-1) - self._curnode.append(block) - self._curfile = blockfname - - - def handle_if(self, span, cond): - '''Should be called to signalize an if directive. - - Args: - span (tuple of int): Start and end line of the directive. - param (str): String representation of the branching condition. - ''' - self._path.append(self._curnode) - self._curnode = [] - self._open_blocks.append(('if', self._curfile, [span], [cond], [])) - - - def handle_elif(self, span, cond): - '''Should be called to signalize an elif directive. - - Args: - span (tuple of int): Start and end line of the directive. - cond (str): String representation of the branching condition. - ''' - self._check_for_open_block(span, 'elif') - block = self._open_blocks[-1] - directive, _, spans = block[0:3] - self._check_if_matches_last(directive, 'if', spans[-1], span, 'elif') - conds, contents = block[3:5] - conds.append(cond) - contents.append(self._curnode) - spans.append(span) - self._curnode = [] - - - def handle_else(self, span): - '''Should be called to signalize an else directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._check_for_open_block(span, 'else') - block = self._open_blocks[-1] - directive, _, spans = block[0:3] - self._check_if_matches_last(directive, 'if', spans[-1], span, 'else') - conds, contents = block[3:5] - conds.append('True') - contents.append(self._curnode) - spans.append(span) - self._curnode = [] - - - def handle_endif(self, span): - '''Should be called to signalize an endif directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._check_for_open_block(span, 'endif') - block = self._open_blocks.pop(-1) - directive, _, spans = block[0:3] - self._check_if_matches_last(directive, 'if', spans[-1], span, 'endif') - _, contents = block[3:5] - contents.append(self._curnode) - spans.append(span) - self._curnode = self._path.pop(-1) - self._curnode.append(block) - - - def handle_for(self, span, loopvar, iterator): - '''Should be called to signalize a for directive. - - Args: - span (tuple of int): Start and end line of the directive. - varexpr (str): String representation of the loop variable - expression. - iterator (str): String representation of the iterable. - ''' - self._path.append(self._curnode) - self._curnode = [] - self._open_blocks.append(('for', self._curfile, [span], loopvar, - iterator, None)) - - - def handle_endfor(self, span): - '''Should be called to signalize an endfor directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._check_for_open_block(span, 'endfor') - block = self._open_blocks.pop(-1) - directive, fname, spans = block[0:3] - self._check_if_matches_last(directive, 'for', spans[-1], span, 'endfor') - loopvar, iterator, dummy = block[3:6] - spans.append(span) - block = (directive, fname, spans, loopvar, iterator, self._curnode) - self._curnode = self._path.pop(-1) - self._curnode.append(block) - - - def handle_def(self, span, name, argexpr): - '''Should be called to signalize a def directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the macro to be defined. - argexpr (str): Macro argument definition or None - ''' - self._path.append(self._curnode) - self._curnode = [] - defblock = ('def', self._curfile, [span], name, argexpr, None) - self._open_blocks.append(defblock) - - - def handle_enddef(self, span, name): - '''Should be called to signalize an enddef directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the enddef statement. Could be None, if enddef - was specified without name. - ''' - self._check_for_open_block(span, 'enddef') - block = self._open_blocks.pop(-1) - directive, fname, spans = block[0:3] - self._check_if_matches_last(directive, 'def', spans[-1], span, 'enddef') - defname, argexpr, dummy = block[3:6] - if name is not None and name != defname: - msg = "wrong name in enddef directive "\ - "(expected '{0}', got '{1}')".format(defname, name) - raise FyppFatalError(msg, fname, span) - spans.append(span) - block = (directive, fname, spans, defname, argexpr, self._curnode) - self._curnode = self._path.pop(-1) - self._curnode.append(block) - - - def handle_call(self, span, name, argexpr, blockcall): - '''Should be called to signalize a call directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the callable to call - argexpr (str or None): Argument expression containing additional - arguments for the call. - blockcall (bool): Whether the alternative "block / contains / - endblock" calling directive has been used. - ''' - self._path.append(self._curnode) - self._curnode = [] - directive = 'block' if blockcall else 'call' - self._open_blocks.append( - (directive, self._curfile, [span, span], name, argexpr, [], [])) - - - def handle_nextarg(self, span, name, blockcall): - '''Should be called to signalize a nextarg directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str or None): Name of the argument following next or - None if it should be the next positional argument. - blockcall (bool): Whether the alternative "block / contains / - endblock" calling directive has been used. - ''' - self._check_for_open_block(span, 'nextarg') - block = self._open_blocks[-1] - directive, fname, spans = block[0:3] - if blockcall: - opened, current = 'block', 'contains' - else: - opened, current = 'call', 'nextarg' - self._check_if_matches_last(directive, opened, spans[-1], span, current) - args, argnames = block[5:7] - args.append(self._curnode) - spans.append(span) - if name is not None: - argnames.append(name) - elif argnames: - msg = 'non-keyword argument following keyword argument' - raise FyppFatalError(msg, fname, span) - self._curnode = [] - - - def handle_endcall(self, span, name, blockcall): - '''Should be called to signalize an endcall directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the endcall statement. Could be None, if endcall - was specified without name. - blockcall (bool): Whether the alternative "block / contains / - endblock" calling directive has been used. - ''' - self._check_for_open_block(span, 'endcall') - block = self._open_blocks.pop(-1) - directive, fname, spans = block[0:3] - callname, callargexpr, args, argnames = block[3:7] - if blockcall: - opened, current = 'block', 'endblock' - else: - opened, current = 'call', 'endcall' - self._check_if_matches_last(directive, opened, spans[0], span, current) - - if name is not None and name != callname: - msg = "wrong name in {0} directive "\ - "(expected '{1}', got '{2}')".format(current, callname, name) - raise FyppFatalError(msg, fname, span) - args.append(self._curnode) - # If nextarg or endcall immediately followed call, then first argument - # is empty and should be removed (to allow for calls without arguments - # and named first argument in calls) - if args and not args[0]: - if len(argnames) == len(args): - del argnames[0] - del args[0] - del spans[1] - spans.append(span) - block = (directive, fname, spans, callname, callargexpr, args, argnames) - self._curnode = self._path.pop(-1) - self._curnode.append(block) - - - def handle_set(self, span, name, expr): - '''Should be called to signalize a set directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the variable. - expr (str): String representation of the expression to be assigned - to the variable. - ''' - self._curnode.append(('set', self._curfile, span, name, expr)) - - - def handle_global(self, span, name): - '''Should be called to signalize a global directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the variable(s) to make global. - ''' - self._curnode.append(('global', self._curfile, span, name)) - - - def handle_del(self, span, name): - '''Should be called to signalize a del directive. - - Args: - span (tuple of int): Start and end line of the directive. - name (str): Name of the variable(s) to delete. - ''' - self._curnode.append(('del', self._curfile, span, name)) - - - def handle_eval(self, span, expr): - '''Should be called to signalize an eval directive. - - Args: - span (tuple of int): Start and end line of the directive. - expr (str): String representation of the Python expression to - be evaluated. - ''' - self._curnode.append(('eval', self._curfile, span, expr)) - - - def handle_comment(self, span): - '''Should be called to signalize a comment directive. - - The content of the comment is not needed by the builder, but it needs - the span of the comment to generate proper line numbers if needed. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._curnode.append(('comment', self._curfile, span)) - - - def handle_text(self, span, txt): - '''Should be called to pass text which goes to output unaltered. - - Args: - span (tuple of int): Start and end line of the text. - txt (str): Text. - ''' - self._curnode.append(('txt', self._curfile, span, txt)) - - - def handle_mute(self, span): - '''Should be called to signalize a mute directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._path.append(self._curnode) - self._curnode = [] - self._open_blocks.append(('mute', self._curfile, [span], None)) - - - def handle_endmute(self, span): - '''Should be called to signalize an endmute directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._check_for_open_block(span, 'endmute') - block = self._open_blocks.pop(-1) - directive, fname, spans = block[0:3] - self._check_if_matches_last(directive, 'mute', spans[-1], span, - 'endmute') - spans.append(span) - block = (directive, fname, spans, self._curnode) - self._curnode = self._path.pop(-1) - self._curnode.append(block) - - - def handle_stop(self, span, msg): - '''Should be called to signalize a stop directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._curnode.append(('stop', self._curfile, span, msg)) - - - def handle_assert(self, span, cond): - '''Should be called to signalize an assert directive. - - Args: - span (tuple of int): Start and end line of the directive. - ''' - self._curnode.append(('assert', self._curfile, span, cond)) - - - @property - def tree(self): - '''Returns the tree built by the Builder.''' - return self._tree - - - def _check_for_open_block(self, span, directive): - if len(self._open_blocks) <= self._nr_prev_blocks[-1]: - msg = 'unexpected {0} directive'.format(directive) - raise FyppFatalError(msg, self._curfile, span) - - - def _check_if_matches_last(self, lastdir, curdir, lastspan, curspan, - directive): - if curdir != lastdir: - msg = "mismatching '{0}' directive (last block opened was '{1}')"\ - .format(directive, lastdir) - raise FyppFatalError(msg, self._curfile, curspan) - inline_last = lastspan[0] == lastspan[1] - inline_cur = curspan[0] == curspan[1] - if inline_last != inline_cur: - if inline_cur: - msg = 'expecting line form of directive {0}'.format(directive) - else: - msg = 'expecting inline form of directive {0}'.format(directive) - raise FyppFatalError(msg, self._curfile, curspan) - elif inline_cur and curspan[0] != lastspan[0]: - msg = 'inline directives of the same construct must be in the '\ - 'same row' - raise FyppFatalError(msg, self._curfile, curspan) - - -class Renderer: - - ''''Renders a tree. - - Args: - evaluator (Evaluator, optional): Evaluator to use when rendering eval - directives. If None (default), Evaluator() is used. - linenums (bool, optional): Whether linenums should be generated, - defaults to False. - contlinenums (bool, optional): Whether linenums for continuation - should be generated, defaults to False. - linenumformat (str, optional): If set to "gfortran5", a workaround - for broken gfortran versions (version 5.1 and above) is applied when - emitting line numbering directives. - linefolder (callable): Callable to use when folding a line. - ''' - - def __init__(self, evaluator=None, linenums=False, contlinenums=False, - linenumformat=None, linefolder=None): - # Evaluator to use for Python expressions - self._evaluator = Evaluator() if evaluator is None else evaluator - - # Whether rendered output is diverted and will be processed - # further before output (if True: no line numbering and post processing) - self._diverted = False - - # Whether file name and line numbers should be kept fixed and - # not updated (typically when rendering macro content) - self._fixedposition = False - - # Whether line numbering directives should be emitted - self._linenums = linenums - - # Whether line numbering directives in continuation lines are needed. - self._contlinenums = contlinenums - - # Whether to use the fix for GFortran in the line numbering directives - self._linenum_gfortran5 = (linenumformat == 'gfortran5') - - # Callable to be used for folding lines - if linefolder is None: - self._linefolder = lambda line: [line] - else: - self._linefolder = linefolder - - - def render(self, tree, divert=False, fixposition=False): - '''Renders a tree. - - Args: - tree (fypp-tree): Tree to render. - divert (bool): Whether output will be diverted and sent for further - processing, so that no line numbering directives and - postprocessing are needed at this stage. (Default: False) - fixposition (bool): Whether file name and line position (variables - _FILE_ and _LINE_) should be kept at their current values or - should be updated continuously. (Default: False). - - Returns: str: Rendered string. - ''' - diverted = self._diverted - self._diverted = divert - fixedposition_old = self._fixedposition - self._fixedposition = self._fixedposition or fixposition - output, eval_inds, eval_pos = self._render(tree) - if not self._diverted and eval_inds: - self._postprocess_eval_lines(output, eval_inds, eval_pos) - self._diverted = diverted - self._fixedposition = fixedposition_old - txt = ''.join(output) - - return txt - - - def _render(self, tree): - output = [] - eval_inds = [] - eval_pos = [] - for node in tree: - cmd = node[0] - if cmd == 'txt': - output.append(node[3]) - elif cmd == 'if': - out, ieval, peval = self._get_conditional_content(*node[1:5]) - eval_inds += _shiftinds(ieval, len(output)) - eval_pos += peval - output += out - elif cmd == 'eval': - out, ieval, peval = self._get_eval(*node[1:4]) - eval_inds += _shiftinds(ieval, len(output)) - eval_pos += peval - output += out - elif cmd == 'def': - result = self._define_macro(*node[1:6]) - output.append(result) - elif cmd == 'set': - result = self._define_variable(*node[1:5]) - output.append(result) - elif cmd == 'del': - self._delete_variable(*node[1:4]) - elif cmd == 'for': - out, ieval, peval = self._get_iterated_content(*node[1:6]) - eval_inds += _shiftinds(ieval, len(output)) - eval_pos += peval - output += out - elif cmd == 'call' or cmd == 'block': - out, ieval, peval = self._get_called_content(*node[1:7]) - eval_inds += _shiftinds(ieval, len(output)) - eval_pos += peval - output += out - elif cmd == 'include': - out, ieval, peval = self._get_included_content(*node[1:5]) - eval_inds += _shiftinds(ieval, len(output)) - eval_pos += peval - output += out - elif cmd == 'comment': - output.append(self._get_comment(*node[1:3])) - elif cmd == 'mute': - output.append(self._get_muted_content(*node[1:4])) - elif cmd == 'stop': - self._handle_stop(*node[1:4]) - elif cmd == 'assert': - result = self._handle_assert(*node[1:4]) - output.append(result) - elif cmd == 'global': - self._add_global(*node[1:4]) - else: - msg = "internal error: unknown command '{0}'".format(cmd) - raise FyppFatalError(msg) - return output, eval_inds, eval_pos - - - def _get_eval(self, fname, span, expr): - try: - result = self._evaluate(expr, fname, span[0]) - except Exception as exc: - msg = "exception occured when evaluating '{0}'".format(expr) - raise FyppFatalError(msg, fname, span, exc) - out = [] - ieval = [] - peval = [] - if result is not None: - out.append(str(result)) - if not self._diverted: - ieval.append(0) - peval.append((span, fname)) - if span[0] != span[1]: - out.append('\n') - return out, ieval, peval - - - def _get_conditional_content(self, fname, spans, conditions, contents): - out = [] - ieval = [] - peval = [] - multiline = (spans[0][0] != spans[-1][1]) - for condition, content, span in zip(conditions, contents, spans): - try: - cond = bool(self._evaluate(condition, fname, span[0])) - except Exception as exc: - msg = "exception occured when evaluating '{0}'"\ - .format(condition) - raise FyppFatalError(msg, fname, span, exc) - if cond: - if self._linenums and not self._diverted and multiline: - out.append(linenumdir(span[1], fname)) - outcont, ievalcont, pevalcont = self._render(content) - ieval += _shiftinds(ievalcont, len(out)) - peval += pevalcont - out += outcont - break - if self._linenums and not self._diverted and multiline: - out.append(linenumdir(spans[-1][1], fname)) - return out, ieval, peval - - - def _get_iterated_content(self, fname, spans, loopvars, loopiter, content): - out = [] - ieval = [] - peval = [] - try: - iterobj = iter(self._evaluate(loopiter, fname, spans[0][0])) - except Exception as exc: - msg = "exception occured when evaluating '{0}'"\ - .format(loopiter) - raise FyppFatalError(msg, fname, spans[0], exc) - multiline = (spans[0][0] != spans[-1][1]) - for var in iterobj: - if len(loopvars) == 1: - self._define(loopvars[0], var) - else: - for varname, value in zip(loopvars, var): - self._define(varname, value) - if self._linenums and not self._diverted and multiline: - out.append(linenumdir(spans[0][1], fname)) - outcont, ievalcont, pevalcont = self._render(content) - ieval += _shiftinds(ievalcont, len(out)) - peval += pevalcont - out += outcont - if self._linenums and not self._diverted and multiline: - out.append(linenumdir(spans[1][1], fname)) - return out, ieval, peval - - - def _get_called_content(self, fname, spans, name, argexpr, contents, - argnames): - posargs, kwargs = self._get_call_arguments(fname, spans, argexpr, - contents, argnames) - try: - callobj = self._evaluate(name, fname, spans[0][0]) - result = callobj(*posargs, **kwargs) - except Exception as exc: - msg = "exception occured when calling '{0}'".format(name) - raise FyppFatalError(msg, fname, spans[0], exc) - self._update_predef_globals(fname, spans[0][0]) - span = (spans[0][0], spans[-1][1]) - out = [] - ieval = [] - peval = [] - if result is not None: - out = [str(result)] - if not self._diverted: - ieval = [0] - peval = [(span, fname)] - if span[0] != span[1]: - out.append('\n') - return out, ieval, peval - - - def _get_call_arguments(self, fname, spans, argexpr, contents, argnames): - if argexpr is None: - posargs = [] - kwargs = {} - else: - # Parse and evaluate arguments passed in call header - self._evaluator.openscope() - try: - posargs, kwargs = self._evaluate( - '__getargvalues(' + argexpr + ')', fname, spans[0][0]) - except Exception as exc: - msg = "unable to parse argument expression '{0}'"\ - .format(argexpr) - raise FyppFatalError(msg, fname, spans[0], exc) - self._evaluator.closescope() - - # Render arguments passed in call body - args = [] - for content in contents: - self._evaluator.openscope() - rendered = self.render(content, divert=True) - self._evaluator.closescope() - if rendered.endswith('\n'): - rendered = rendered[:-1] - args.append(rendered) - - # Separate arguments in call body into positional and keyword ones: - if argnames: - posargs += args[:len(args) - len(argnames)] - offset = len(args) - len(argnames) - for iargname, argname in enumerate(argnames): - ind = offset + iargname - if argname in kwargs: - msg = "keyword argument '{0}' already defined"\ - .format(argname) - raise FyppFatalError(msg, fname, spans[ind + 1]) - kwargs[argname] = args[ind] - else: - posargs += args - - return posargs, kwargs - - - def _get_included_content(self, fname, spans, includefname, content): - includefile = spans[0] is not None - out = [] - if self._linenums and not self._diverted: - if includefile or self._linenum_gfortran5: - out += linenumdir(0, includefname, _LINENUM_NEW_FILE) - else: - out += linenumdir(0, includefname) - outcont, ieval, peval = self._render(content) - ieval = _shiftinds(ieval, len(out)) - out += outcont - if self._linenums and not self._diverted and includefile: - out += linenumdir(spans[0][1], fname, _LINENUM_RETURN_TO_FILE) - return out, ieval, peval - - - def _define_macro(self, fname, spans, name, argexpr, content): - if argexpr is None: - args = [] - defaults = {} - varpos = None - varkw = None - else: - # Try to create a lambda function with the argument expression - self._evaluator.openscope() - lambdaexpr = 'lambda ' + argexpr + ': None' - try: - func = self._evaluate(lambdaexpr, fname, spans[0][0]) - except Exception as exc: - msg = "exception occured when evaluating argument expression "\ - "'{0}'".format(argexpr) - raise FyppFatalError(msg, fname, spans[0], exc) - self._evaluator.closescope() - try: - args, defaults, varpos, varkw = _GET_CALLABLE_ARGSPEC(func) - except Exception as exc: - msg = "invalid argument expression '{0}'".format(argexpr) - raise FyppFatalError(msg, fname, spans[0], exc) - named_args = args if varpos is None else args + [varpos] - named_args = named_args if varkw is None else named_args + [varkw] - for arg in named_args: - if arg in _RESERVED_NAMES or arg.startswith(_RESERVED_PREFIX): - msg = "invalid argument name '{0}'".format(arg) - raise FyppFatalError(msg, fname, spans[0]) - result = '' - try: - macro = _Macro( - name, fname, spans, args, defaults, varpos, varkw, content, - self, self._evaluator, self._evaluator.localscope) - self._define(name, macro) - except Exception as exc: - msg = "exception occured when defining macro '{0}'"\ - .format(name) - raise FyppFatalError(msg, fname, spans[0], exc) - if self._linenums and not self._diverted: - result = linenumdir(spans[1][1], fname) - return result - - - def _define_variable(self, fname, span, name, valstr): - result = '' - try: - if valstr is None: - expr = None - else: - expr = self._evaluate(valstr, fname, span[0]) - self._define(name, expr) - except Exception as exc: - msg = "exception occured when setting variable(s) '{0}' to '{1}'"\ - .format(name, valstr) - raise FyppFatalError(msg, fname, span, exc) - multiline = (span[0] != span[1]) - if self._linenums and not self._diverted and multiline: - result = linenumdir(span[1], fname) - return result - - - def _delete_variable(self, fname, span, name): - result = '' - try: - self._evaluator.undefine(name) - except Exception as exc: - msg = "exception occured when deleting variable(s) '{0}'"\ - .format(name) - raise FyppFatalError(msg, fname, span, exc) - multiline = (span[0] != span[1]) - if self._linenums and not self._diverted and multiline: - result = linenumdir(span[1], fname) - return result - - - def _add_global(self, fname, span, name): - result = '' - try: - self._evaluator.addglobal(name) - except Exception as exc: - msg = "exception occured when making variable(s) '{0}' global"\ - .format(name) - raise FyppFatalError(msg, fname, span, exc) - multiline = (span[0] != span[1]) - if self._linenums and not self._diverted and multiline: - result = linenumdir(span[1], fname) - return result - - - def _get_comment(self, fname, span): - if self._linenums and not self._diverted: - return linenumdir(span[1], fname) - return '' - - - def _get_muted_content(self, fname, spans, content): - self._render(content) - if self._linenums and not self._diverted: - return linenumdir(spans[-1][1], fname) - return '' - - - def _handle_stop(self, fname, span, msgstr): - try: - msg = str(self._evaluate(msgstr, fname, span[0])) - except Exception as exc: - msg = "exception occured when evaluating stop message '{0}'"\ - .format(msgstr) - raise FyppFatalError(msg, fname, span, exc) - raise FyppStopRequest(msg, fname, span) - - - def _handle_assert(self, fname, span, expr): - result = '' - try: - cond = bool(self._evaluate(expr, fname, span[0])) - except Exception as exc: - msg = "exception occured when evaluating assert condition '{0}'"\ - .format(expr) - raise FyppFatalError(msg, fname, span, exc) - if not cond: - msg = "Assertion failed ('{0}')".format(expr) - raise FyppStopRequest(msg, fname, span) - if self._linenums and not self._diverted: - result = linenumdir(span[1], fname) - return result - - - def _evaluate(self, expr, fname, linenr): - self._update_predef_globals(fname, linenr) - result = self._evaluator.evaluate(expr) - self._update_predef_globals(fname, linenr) - return result - - - def _update_predef_globals(self, fname, linenr): - self._evaluator.updatelocals( - _DATE_=time.strftime('%Y-%m-%d'), _TIME_=time.strftime('%H:%M:%S'), - _THIS_FILE_=fname, _THIS_LINE_=linenr + 1) - if not self._fixedposition: - self._evaluator.updateglobals(_FILE_=fname, _LINE_=linenr + 1) - - - def _define(self, var, value): - self._evaluator.define(var, value) - - - def _postprocess_eval_lines(self, output, eval_inds, eval_pos): - ilastproc = -1 - for ieval, ind in enumerate(eval_inds): - span, fname = eval_pos[ieval] - if ind <= ilastproc: - continue - iprev, eolprev = self._find_last_eol(output, ind) - inext, eolnext = self._find_next_eol(output, ind) - curline = self._glue_line(output, ind, iprev, eolprev, inext, - eolnext) - output[iprev + 1:inext] = [''] * (inext - iprev - 1) - output[ind] = self._postprocess_eval_line(curline, fname, span) - ilastproc = inext - - - @staticmethod - def _find_last_eol(output, ind): - 'Find last newline before current position.' - iprev = ind - 1 - while iprev >= 0: - eolprev = output[iprev].rfind('\n') - if eolprev != -1: - break - iprev -= 1 - else: - iprev = 0 - eolprev = -1 - return iprev, eolprev - - - @staticmethod - def _find_next_eol(output, ind): - 'Find last newline before current position.' - # find first eol after expr. evaluation - inext = ind + 1 - while inext < len(output): - eolnext = output[inext].find('\n') - if eolnext != -1: - break - inext += 1 - else: - inext = len(output) - 1 - eolnext = len(output[-1]) - 1 - return inext, eolnext - - - @staticmethod - def _glue_line(output, ind, iprev, eolprev, inext, eolnext): - 'Create line from parts between specified boundaries.' - curline_parts = [] - if iprev != ind: - curline_parts = [output[iprev][eolprev + 1:]] - output[iprev] = output[iprev][:eolprev + 1] - curline_parts.extend(output[iprev + 1:ind]) - curline_parts.extend(output[ind]) - curline_parts.extend(output[ind + 1:inext]) - if inext != ind: - curline_parts.append(output[inext][:eolnext + 1]) - output[inext] = output[inext][eolnext + 1:] - return ''.join(curline_parts) - - - def _postprocess_eval_line(self, evalline, fname, span): - lines = evalline.split('\n') - # If line ended on '\n', last element is ''. We remove it and - # add the trailing newline later manually. - trailing_newline = (lines[-1] == '') - if trailing_newline: - del lines[-1] - lnum = linenumdir(span[0], fname) if self._linenums else '' - clnum = lnum if self._contlinenums else '' - linenumsep = '\n' + lnum - clinenumsep = '\n' + clnum - foldedlines = [self._foldline(line) for line in lines] - outlines = [clinenumsep.join(lines) for lines in foldedlines] - result = linenumsep.join(outlines) - # Add missing trailing newline - if trailing_newline: - trailing = '\n' - if self._linenums: - # Last line was folded, but no linenums were generated for - # the continuation lines -> current line position is not - # in sync with the one calculated from the last line number - unsync = ( - len(foldedlines) and len(foldedlines[-1]) > 1 - and not self._contlinenums) - # Eval directive in source consists of more than one line - multiline = span[1] - span[0] > 1 - if unsync or multiline: - # For inline eval directives span[0] == span[1] - # -> next line is span[0] + 1 and not span[1] as for - # line eval directives - nextline = max(span[1], span[0] + 1) - trailing += linenumdir(nextline, fname) - else: - trailing = '' - return result + trailing - - - def _foldline(self, line): - if _COMMENTLINE_REGEXP.match(line) is None: - return self._linefolder(line) - return [line] - - -class Evaluator: - - '''Provides an isolated environment for evaluating Python expressions. - - It restricts the builtins which can be used within this environment to a - (hopefully safe) subset. Additionally it defines the functions which are - provided by the preprocessor for the eval directives. - - Args: - env (dict, optional): Initial definitions for the environment, defaults - to None. - ''' - - # Restricted builtins working in all supported Python verions. Version - # specific ones are added dynamically in _get_restricted_builtins(). - _RESTRICTED_BUILTINS = { - 'abs': builtins.abs, - 'all': builtins.all, - 'any': builtins.any, - 'bin': builtins.bin, - 'bool': builtins.bool, - 'bytearray': builtins.bytearray, - 'bytes': builtins.bytes, - 'chr': builtins.chr, - 'classmethod': builtins.classmethod, - 'complex': builtins.complex, - 'delattr': builtins.delattr, - 'dict': builtins.dict, - 'dir': builtins.dir, - 'divmod': builtins.divmod, - 'enumerate': builtins.enumerate, - 'filter': builtins.filter, - 'float': builtins.float, - 'format': builtins.format, - 'frozenset': builtins.frozenset, - 'getattr': builtins.getattr, - 'globals': builtins.globals, - 'hasattr': builtins.hasattr, - 'hash': builtins.hash, - 'hex': builtins.hex, - 'id': builtins.id, - 'int': builtins.int, - 'isinstance': builtins.isinstance, - 'issubclass': builtins.issubclass, - 'iter': builtins.iter, - 'len': builtins.len, - 'list': builtins.list, - 'locals': builtins.locals, - 'map': builtins.map, - 'max': builtins.max, - 'min': builtins.min, - 'next': builtins.next, - 'object': builtins.object, - 'oct': builtins.oct, - 'ord': builtins.ord, - 'pow': builtins.pow, - 'property': builtins.property, - 'range': builtins.range, - 'repr': builtins.repr, - 'reversed': builtins.reversed, - 'round': builtins.round, - 'set': builtins.set, - 'setattr': builtins.setattr, - 'slice': builtins.slice, - 'sorted': builtins.sorted, - 'staticmethod': builtins.staticmethod, - 'str': builtins.str, - 'sum': builtins.sum, - 'super': builtins.super, - 'tuple': builtins.tuple, - 'type': builtins.type, - 'vars': builtins.vars, - 'zip': builtins.zip, - } - - - def __init__(self, env=None): - - # Global scope - self._globals = env if env is not None else {} - - # Local scope(s) - self._locals = None - self._locals_stack = [] - - # Variables which are references to entries in global scope - self._globalrefs = None - self._globalrefs_stack = [] - - # Current scope (globals + locals in all embedding and in current scope) - self._scope = self._globals - - # Turn on restricted mode - self._restrict_builtins() - - - def evaluate(self, expr): - '''Evaluate a Python expression using the `eval()` builtin. - - Args: - expr (str): String represantion of the expression. - - Return: - Python object: Result of the expression evaluation. - ''' - result = eval(expr, self._scope) - return result - - - def import_module(self, module): - '''Import a module into the evaluator. - - Note: Import only trustworthy modules! Module imports are global, - therefore, importing a malicious module which manipulates other global - modules could affect code behaviour outside of the Evaluator as well. - - Args: - module (str): Python module to import. - - Raises: - FyppFatalError: If module could not be imported. - - ''' - rootmod = module.split('.', 1)[0] - try: - imported = __import__(module, self._scope) - self.define(rootmod, imported) - except Exception as exc: - msg = "failed to import module '{0}'".format(module) - raise FyppFatalError(msg, cause=exc) - - - def define(self, name, value): - '''Define a Python entity. - - Args: - name (str): Name of the entity. - value (Python object): Value of the entity. - - Raises: - FyppFatalError: If name starts with the reserved prefix or if it is - a reserved name. - ''' - varnames = self._get_variable_names(name) - if len(varnames) == 1: - value = (value,) - elif len(varnames) != len(value): - msg = 'value for tuple assignment has incompatible length' - raise FyppFatalError(msg) - for varname, varvalue in zip(varnames, value): - self._check_variable_name(varname) - if self._locals is None: - self._globals[varname] = varvalue - else: - if varname in self._globalrefs: - self._globals[varname] = varvalue - else: - self._locals[varname] = varvalue - self._scope[varname] = varvalue - - - def undefine(self, name): - '''Undefine a Python entity. - - Args: - name (str): Name of the entity to undefine. - - Raises: - FyppFatalError: If name starts with the reserved prefix or if it is - a reserved name. - ''' - varnames = self._get_variable_names(name) - for varname in varnames: - self._check_variable_name(varname) - deleted = False - if self._locals is None: - if varname in self._globals: - del self._globals[varname] - deleted = True - else: - if varname in self._locals: - del self._locals[varname] - del self._scope[varname] - deleted = True - elif varname in self._globalrefs and varname in self._globals: - del self._globals[varname] - del self._scope[varname] - deleted = True - if not deleted: - msg = "lookup for an erasable instance of '{0}' failed"\ - .format(varname) - raise FyppFatalError(msg) - - - def addglobal(self, name): - '''Define a given entity as global. - - Args: - name (str): Name of the entity to make global. - - Raises: - FyppFatalError: If entity name is invalid or if the current scope is - a local scope and entity is already defined in it. - ''' - varnames = self._get_variable_names(name) - for varname in varnames: - self._check_variable_name(varname) - if self._locals is not None: - if varname in self._locals: - msg = "variable '{0}' already defined in local scope"\ - .format(varname) - raise FyppFatalError(msg) - self._globalrefs.add(varname) - - - def updateglobals(self, **vardict): - '''Update variables in the global scope. - - This is a shortcut function to inject protected variables in the global - scope without extensive checks (as in define()). Vardict must not - contain any global entries which can be shadowed in local scopes - (e.g. should only contain variables with forbidden prefix). - - Args: - **vardict: variable defintions. - - ''' - self._scope.update(vardict) - if self._locals is not None: - self._globals.update(vardict) - - - def updatelocals(self, **vardict): - '''Update variables in the local scope. - - This is a shortcut function to inject variables in the local scope - without extensive checks (as in define()). Vardict must not contain any - entries which have been made global via addglobal() before. In order to - ensure this, updatelocals() should be called immediately after - openscope(), or with variable names, which are warrantedly not globals - (e.g variables starting with forbidden prefix) - - Args: - **vardict: variable defintions. - ''' - self._scope.update(vardict) - if self._locals is not None: - self._locals.update(vardict) - - - def openscope(self, customlocals=None): - '''Opens a new (embedded) scope. - - Args: - customlocals (dict): By default, the locals of the embedding scope - are visible in the new one. When this is not the desired - behaviour a dictionary of customized locals can be passed, - and those locals will become the only visible ones. - ''' - self._locals_stack.append(self._locals) - self._globalrefs_stack.append(self._globalrefs) - if customlocals is not None: - self._locals = customlocals.copy() - elif self._locals is not None: - self._locals = self._locals.copy() - else: - self._locals = {} - self._globalrefs = set() - self._scope = self._globals.copy() - self._scope.update(self._locals) - - - def closescope(self): - '''Close scope and restore embedding scope.''' - self._locals = self._locals_stack.pop(-1) - self._globalrefs = self._globalrefs_stack.pop(-1) - if self._locals is not None: - self._scope = self._globals.copy() - self._scope.update(self._locals) - else: - self._scope = self._globals - - - @property - def globalscope(self): - 'Dictionary of the global scope.' - return self._globals - - - @property - def localscope(self): - 'Dictionary of the current local scope.' - return self._locals - - - def _restrict_builtins(self): - builtindict = self._get_restricted_builtins() - builtindict['__import__'] = self._func_import - builtindict['defined'] = self._func_defined - builtindict['setvar'] = self._func_setvar - builtindict['getvar'] = self._func_getvar - builtindict['delvar'] = self._func_delvar - builtindict['globalvar'] = self._func_globalvar - builtindict['__getargvalues'] = self._func_getargvalues - self._globals['__builtins__'] = builtindict - - - @classmethod - def _get_restricted_builtins(cls): - bidict = dict(cls._RESTRICTED_BUILTINS) - major = sys.version_info[0] - if major == 2: - bidict['True'] = True - bidict['False'] = False - return bidict - - - @staticmethod - def _get_variable_names(varexpr): - lpar = varexpr.startswith('(') - rpar = varexpr.endswith(')') - if lpar != rpar: - msg = "unbalanced paranthesis around variable varexpr(s) in '{0}'"\ - .format(varexpr) - raise FyppFatalError(msg, None, None) - if lpar: - varexpr = varexpr[1:-1] - varnames = [s.strip() for s in varexpr.split(',')] - return varnames - - - @staticmethod - def _check_variable_name(varname): - if varname.startswith(_RESERVED_PREFIX): - msg = "Name '{0}' starts with reserved prefix '{1}'"\ - .format(varname, _RESERVED_PREFIX) - raise FyppFatalError(msg, None, None) - if varname in _RESERVED_NAMES: - msg = "Name '{0}' is reserved and can not be redefined"\ - .format(varname) - raise FyppFatalError(msg, None, None) - - - def _func_defined(self, var): - defined = var in self._scope - return defined - - - def _func_import(self, name, *_, **__): - module = self._scope.get(name, None) - if module is not None and isinstance(module, types.ModuleType): - return module - msg = "Import of module '{0}' via '__import__' not allowed".format(name) - raise ImportError(msg) - - - def _func_setvar(self, *namesvalues): - if len(namesvalues) % 2: - msg = 'setvar function needs an even number of arguments' - raise FyppFatalError(msg) - for ind in range(0, len(namesvalues), 2): - self.define(namesvalues[ind], namesvalues[ind + 1]) - - - def _func_getvar(self, name, defvalue=None): - if name in self._scope: - return self._scope[name] - return defvalue - - - def _func_delvar(self, *names): - for name in names: - self.undefine(name) - - - def _func_globalvar(self, *names): - for name in names: - self.addglobal(name) - - - @staticmethod - def _func_getargvalues(*args, **kwargs): - return list(args), kwargs - - - -class _Macro: - - '''Represents a user defined macro. - - This object should only be initiatied by a Renderer instance, as it - needs access to Renderers internal variables and methods. - - Args: - name (str): Name of the macro. - fname (str): The file where the macro was defined. - spans (str): Line spans of macro defintion. - argnames (list of str): Macro dummy arguments. - varpos (str): Name of variable positional argument or None. - varkw (str): Name of variable keyword argument or None. - content (list): Content of the macro as tree. - renderer (Renderer): Renderer to use for evaluating macro content. - localscope (dict): Dictionary with local variables, which should be used - the local scope, when the macro is called. Default: None (empty - local scope). - ''' - - def __init__(self, name, fname, spans, argnames, defaults, varpos, varkw, - content, renderer, evaluator, localscope=None): - self._name = name - self._fname = fname - self._spans = spans - self._argnames = argnames - self._defaults = defaults - self._varpos = varpos - self._varkw = varkw - self._content = content - self._renderer = renderer - self._evaluator = evaluator - self._localscope = localscope if localscope is not None else {} - - - def __call__(self, *args, **keywords): - argdict = self._process_arguments(args, keywords) - self._evaluator.openscope(customlocals=self._localscope) - self._evaluator.updatelocals(**argdict) - output = self._renderer.render(self._content, divert=True, - fixposition=True) - self._evaluator.closescope() - if output.endswith('\n'): - return output[:-1] - return output - - - def _process_arguments(self, args, keywords): - kwdict = dict(keywords) - argdict = {} - nargs = min(len(args), len(self._argnames)) - for iarg in range(nargs): - argdict[self._argnames[iarg]] = args[iarg] - if nargs < len(args): - if self._varpos is None: - msg = "macro '{0}' called with too many positional arguments "\ - "(expected: {1}, received: {2})"\ - .format(self._name, len(self._argnames), len(args)) - raise FyppFatalError(msg, self._fname, self._spans[0]) - else: - argdict[self._varpos] = list(args[nargs:]) - elif self._varpos is not None: - argdict[self._varpos] = [] - for argname in self._argnames[:nargs]: - if argname in kwdict: - msg = "got multiple values for argument '{0}'".format(argname) - raise FyppFatalError(msg, self._fname, self._spans[0]) - if nargs < len(self._argnames): - for argname in self._argnames[nargs:]: - if argname in kwdict: - argdict[argname] = kwdict.pop(argname) - elif argname in self._defaults: - argdict[argname] = self._defaults[argname] - else: - msg = "macro '{0}' called without mandatory positional "\ - "argument '{1}'".format(self._name, argname) - raise FyppFatalError(msg, self._fname, self._spans[0]) - if kwdict and self._varkw is None: - kwstr = "', '".join(kwdict.keys()) - msg = "macro '{0}' called with unknown keyword argument(s) '{1}'"\ - .format(self._name, kwstr) - raise FyppFatalError(msg, self._fname, self._spans[0]) - if self._varkw is not None: - argdict[self._varkw] = kwdict - return argdict - - - -class Processor: - - '''Connects various objects with each other to create a processor. - - Args: - parser (Parser, optional): Parser to use for parsing text. If None - (default), `Parser()` is used. - builder (Builder, optional): Builder to use for building the tree - representation of the text. If None (default), `Builder()` is used. - renderer (Renderer, optional): Renderer to use for rendering the - output. If None (default), `Renderer()` is used with a default - Evaluator(). - evaluator (Evaluator, optional): Evaluator to use for evaluating Python - expressions. If None (default), `Evaluator()` is used. - ''' - - def __init__(self, parser=None, builder=None, renderer=None, - evaluator=None): - self._parser = Parser() if parser is None else parser - self._builder = Builder() if builder is None else builder - if renderer is None: - evaluator = Evaluator() if evaluator is None else evaluator - self._renderer = Renderer(evaluator) - else: - self._renderer = renderer - - self._parser.handle_include = self._builder.handle_include - self._parser.handle_endinclude = self._builder.handle_endinclude - self._parser.handle_if = self._builder.handle_if - self._parser.handle_else = self._builder.handle_else - self._parser.handle_elif = self._builder.handle_elif - self._parser.handle_endif = self._builder.handle_endif - self._parser.handle_eval = self._builder.handle_eval - self._parser.handle_text = self._builder.handle_text - self._parser.handle_def = self._builder.handle_def - self._parser.handle_enddef = self._builder.handle_enddef - self._parser.handle_set = self._builder.handle_set - self._parser.handle_del = self._builder.handle_del - self._parser.handle_global = self._builder.handle_global - self._parser.handle_for = self._builder.handle_for - self._parser.handle_endfor = self._builder.handle_endfor - self._parser.handle_call = self._builder.handle_call - self._parser.handle_nextarg = self._builder.handle_nextarg - self._parser.handle_endcall = self._builder.handle_endcall - self._parser.handle_comment = self._builder.handle_comment - self._parser.handle_mute = self._builder.handle_mute - self._parser.handle_endmute = self._builder.handle_endmute - self._parser.handle_stop = self._builder.handle_stop - self._parser.handle_assert = self._builder.handle_assert - - - def process_file(self, fname): - '''Processeses a file. - - Args: - fname (str): Name of the file to process. - - Returns: - str: Processed content. - ''' - self._parser.parsefile(fname) - return self._render() - - - def process_text(self, txt): - '''Processes a string. - - Args: - txt (str): Text to process. - - Returns: - str: Processed content. - ''' - self._parser.parse(txt) - return self._render() - - - def _render(self): - output = self._renderer.render(self._builder.tree) - self._builder.reset() - return ''.join(output) - - -class Fypp: - - '''Fypp preprocessor. - - You can invoke it like :: - - tool = fypp.Fypp() - tool.process_file('file.in', 'file.out') - - to initialize Fypp with default options, process `file.in` and write the - result to `file.out`. If the input should be read from a string, the - ``process_text()`` method can be used:: - - tool = fypp.Fypp() - output = tool.process_text('#:if DEBUG > 0\\nprint *, "DEBUG"\\n#:endif\\n') - - If you want to fine tune Fypps behaviour, pass a customized `FyppOptions`_ - instance at initialization:: - - options = fypp.FyppOptions() - options.fixed_format = True - tool = fypp.Fypp(options) - - Alternatively, you can use the command line parser ``optparse.OptionParser`` - to set options for Fypp. The function ``get_option_parser()`` returns you a - default option parser. You can then use its ``parse_args()`` method to - obtain settings by reading the command line arguments:: - - optparser = fypp.get_option_parser() - options, leftover = optparser.parse_args() - tool = fypp.Fypp(options) - - The command line options can also be passed directly as a list when - calling ``parse_args()``:: - - args = ['-DDEBUG=0', 'input.fpp', 'output.f90'] - optparser = fypp.get_option_parser() - options, leftover = optparser.parse_args(args=args) - tool = fypp.Fypp(options) - - - Args: - options (object): Object containing the settings for Fypp. You typically - would pass a customized `FyppOptions`_ instance or an - ``optparse.Values`` object as returned by the option parser. If not - present, the default settings in `FyppOptions`_ are used. - ''' - - def __init__(self, options=None): - syspath = self._get_syspath_without_scriptdir() - self._adjust_syspath(syspath) - if options is None: - options = FyppOptions() - evaluator = Evaluator() - self._encoding = options.encoding - if options.modules: - self._import_modules(options.modules, evaluator, syspath, - options.moduledirs) - if options.defines: - self._apply_definitions(options.defines, evaluator) - parser = Parser(includedirs=options.includes, encoding=self._encoding) - builder = Builder() - - fixed_format = options.fixed_format - linefolding = not options.no_folding - if linefolding: - folding = 'brute' if fixed_format else options.folding_mode - linelength = 72 if fixed_format else options.line_length - indentation = 5 if fixed_format else options.indentation - prefix = '&' - suffix = '' if fixed_format else '&' - linefolder = FortranLineFolder(linelength, indentation, folding, - prefix, suffix) - else: - linefolder = DummyLineFolder() - linenums = options.line_numbering - contlinenums = (options.line_numbering_mode != 'nocontlines') - self._create_parent_folder = options.create_parent_folder - renderer = Renderer( - evaluator, linenums=linenums, contlinenums=contlinenums, - linenumformat=options.line_marker_format, linefolder=linefolder) - self._preprocessor = Processor(parser, builder, renderer) - - - def process_file(self, infile, outfile=None): - '''Processes input file and writes result to output file. - - Args: - infile (str): Name of the file to read and process. If its value is - '-', input is read from stdin. - outfile (str, optional): Name of the file to write the result to. - If its value is '-', result is written to stdout. If not - present, result will be returned as string. - env (dict, optional): Additional definitions for the evaluator. - - Returns: - str: Result of processed input, if no outfile was specified. - ''' - infile = STDIN if infile == '-' else infile - output = self._preprocessor.process_file(infile) - if outfile is None: - return output - if outfile == '-': - outfile = sys.stdout - else: - outfile = _open_output_file(outfile, self._encoding, - self._create_parent_folder) - outfile.write(output) - if outfile != sys.stdout: - outfile.close() - return None - - - def process_text(self, txt): - '''Processes a string. - - Args: - txt (str): String to process. - env (dict, optional): Additional definitions for the evaluator. - - Returns: - str: Processed content. - ''' - return self._preprocessor.process_text(txt) - - - @staticmethod - def _apply_definitions(defines, evaluator): - for define in defines: - words = define.split('=', 2) - name = words[0] - value = None - if len(words) > 1: - try: - value = evaluator.evaluate(words[1]) - except Exception as exc: - msg = "exception at evaluating '{0}' in definition for " \ - "'{1}'".format(words[1], name) - raise FyppFatalError(msg, cause=exc) - evaluator.define(name, value) - - - def _import_modules(self, modules, evaluator, syspath, moduledirs): - lookuppath = [] - if moduledirs is not None: - lookuppath += [os.path.abspath(moddir) for moddir in moduledirs] - lookuppath.append(os.path.abspath('.')) - lookuppath += syspath - self._adjust_syspath(lookuppath) - for module in modules: - evaluator.import_module(module) - self._adjust_syspath(syspath) - - - @staticmethod - def _get_syspath_without_scriptdir(): - '''Remove the folder of the fypp binary from the search path''' - syspath = list(sys.path) - scriptdir = os.path.abspath(os.path.dirname(sys.argv[0])) - if os.path.abspath(syspath[0]) == scriptdir: - del syspath[0] - return syspath - - - @staticmethod - def _adjust_syspath(syspath): - sys.path = syspath - - -class FyppOptions(optparse.Values): - - '''Container for Fypp options with default values. - - Attributes: - defines (list of str): List of variable definitions in the form of - 'VARNAME=VALUE'. Default: [] - includes (list of str): List of paths to search when looking for include - files. Default: [] - line_numbering (bool): Whether line numbering directives should appear - in the output. Default: False - line_numbering_mode (str): Line numbering mode 'full' or 'nocontlines'. - Default: 'full'. - line_marker_format (str): Line marker format. Currently 'cpp' and - 'gfortran5' are supported. Later fixes the line marker handling bug - introduced in GFortran 5. Default: 'cpp'. - line_length (int): Length of output lines. Default: 132. - folding_mode (str): Folding mode 'smart', 'simple' or 'brute'. Default: - 'smart'. - no_folding (bool): Whether folding should be suppresed. Default: False. - indentation (int): Indentation in continuation lines. Default: 4. - modules (list of str): Modules to import at initialization. Default: []. - moduledirs (list of str): Module lookup directories for importing user - specified modules. The specified paths are looked up *before* the - standard module locations in sys.path. - fixed_format (bool): Whether input file is in fixed format. - Default: False. - encoding (str): Character encoding for reading/writing files. Allowed - values are Pythons codec identifiers, e.g. 'ascii', 'utf-8', etc. - Default: 'utf-8'. Reading from stdin and writing to stdout is always - encoded according to the current locale and is not affected by this - setting. - create_parent_folder (bool): Whether the parent folder for the output - file should be created if it does not exist. Default: False. - ''' - - def __init__(self): - optparse.Values.__init__(self) - self.defines = [] - self.includes = [] - self.line_numbering = False - self.line_numbering_mode = 'full' - self.line_marker_format = 'cpp' - self.line_length = 132 - self.folding_mode = 'smart' - self.no_folding = False - self.indentation = 4 - self.modules = [] - self.moduledirs = [] - self.fixed_format = False - self.encoding = 'utf-8' - self.create_parent_folder = False - - -class FortranLineFolder: - - '''Implements line folding with Fortran continuation lines. - - Args: - maxlen (int, optional): Maximal line length (default: 132). - indent (int, optional): Indentation for continuation lines (default: 4). - method (str, optional): Folding method with following options: - - * ``brute``: folding with maximal length of continuation lines, - * ``simple``: indents with respect of indentation of first line, - * ``smart``: like ``simple``, but tries to fold at whitespaces. - - prefix (str, optional): String to use at the beginning of a continuation - line (default: '&'). - suffix (str, optional): String to use at the end of the line preceeding - a continuation line (default: '&') - ''' - - def __init__(self, maxlen=132, indent=4, method='smart', prefix='&', - suffix='&'): - # Line length should be long enough that contintuation lines can host at - # east one character apart of indentation and two continuation signs - minmaxlen = indent + len(prefix) + len(suffix) + 1 - if maxlen < minmaxlen: - msg = 'Maximal line length less than {0} when using an indentation'\ - ' of {1}'.format(minmaxlen, indent) - raise FyppFatalError(msg) - self._maxlen = maxlen - self._indent = indent - self._prefix = ' ' * self._indent + prefix - self._suffix = suffix - if method not in ['brute', 'smart', 'simple']: - raise FyppFatalError('invalid folding type') - if method == 'brute': - self._inherit_indent = False - self._fold_position_finder = self._get_maximal_fold_pos - elif method == 'simple': - self._inherit_indent = True - self._fold_position_finder = self._get_maximal_fold_pos - elif method == 'smart': - self._inherit_indent = True - self._fold_position_finder = self._get_smart_fold_pos - - - def __call__(self, line): - '''Folds a line. - - Can be directly called to return the list of folded lines:: - - linefolder = FortranLineFolder(maxlen=10) - linefolder(' print *, "some Fortran line"') - - Args: - line (str): Line to fold. - - Returns: - list of str: Components of folded line. They should be - assembled via ``\\n.join()`` to obtain the string - representation. - ''' - if self._maxlen < 0 or len(line) <= self._maxlen: - return [line] - if self._inherit_indent: - indent = len(line) - len(line.lstrip()) - prefix = ' ' * indent + self._prefix - else: - indent = 0 - prefix = self._prefix - suffix = self._suffix - return self._split_line(line, self._maxlen, prefix, suffix, - self._fold_position_finder) - - - @staticmethod - def _split_line(line, maxlen, prefix, suffix, fold_position_finder): - # length of continuation lines with 1 or two continuation chars. - maxlen1 = maxlen - len(prefix) - maxlen2 = maxlen1 - len(suffix) - start = 0 - end = fold_position_finder(line, start, maxlen - len(suffix)) - result = [line[start:end] + suffix] - while end < len(line) - maxlen1: - start = end - end = fold_position_finder(line, start, start + maxlen2) - result.append(prefix + line[start:end] + suffix) - result.append(prefix + line[end:]) - return result - - - @staticmethod - def _get_maximal_fold_pos(_, __, end): - return end - - - @staticmethod - def _get_smart_fold_pos(line, start, end): - linelen = end - start - ispace = line.rfind(' ', start, end) - # The space we waste for smart folding should be max. 1/3rd of the line - if ispace != -1 and ispace >= start + (2 * linelen) // 3: - return ispace - return end - - -class DummyLineFolder: - - '''Implements a dummy line folder returning the line unaltered.''' - - def __call__(self, line): - '''Returns the entire line without any folding. - - Returns: - list of str: Components of folded line. They should be - assembled via ``\\n.join()`` to obtain the string - representation. - ''' - return [line] - - -def get_option_parser(): - '''Returns an option parser for the Fypp command line tool. - - Returns: - OptionParser: Parser which can create an optparse.Values object with - Fypp settings based on command line arguments. - ''' - defs = FyppOptions() - fypp_name = 'fypp' - fypp_desc = 'Preprocesses source code with Fypp directives. The input is '\ - 'read from INFILE (default: \'-\', stdin) and written to '\ - 'OUTFILE (default: \'-\', stdout).' - fypp_version = fypp_name + ' ' + VERSION - usage = '%prog [options] [INFILE] [OUTFILE]' - parser = optparse.OptionParser(prog=fypp_name, description=fypp_desc, - version=fypp_version, usage=usage) - msg = 'define variable, value is interpreted as ' \ - 'Python expression (e.g \'-DDEBUG=1\' sets DEBUG to the ' \ - 'integer 1) or set to None if ommitted' - parser.add_option('-D', '--define', action='append', dest='defines', - metavar='VAR[=VALUE]', default=defs.defines, help=msg) - msg = 'add directory to the search paths for include files' - parser.add_option('-I', '--include', action='append', dest='includes', - metavar='INCDIR', default=defs.includes, help=msg) - msg = 'import a python module at startup (import only trustworthy modules '\ - 'as they have access to an **unrestricted** Python environment!)' - parser.add_option('-m', '--module', action='append', dest='modules', - metavar='MOD', default=defs.modules, help=msg) - msg = 'directory to be searched for user imported modules before '\ - 'looking up standard locations in sys.path' - parser.add_option('-M', '--module-dir', action='append', - dest='moduledirs', metavar='MODDIR', - default=defs.moduledirs, help=msg) - msg = 'emit line numbering markers' - parser.add_option('-n', '--line-numbering', action='store_true', - dest='line_numbering', default=defs.line_numbering, - help=msg) - msg = 'line numbering mode, \'full\' (default): line numbering '\ - 'markers generated whenever source and output lines are out '\ - 'of sync, \'nocontlines\': line numbering markers omitted '\ - 'for continuation lines' - parser.add_option('-N', '--line-numbering-mode', metavar='MODE', - choices=['full', 'nocontlines'], - default=defs.line_numbering_mode, - dest='line_numbering_mode', help=msg) - msg = 'line numbering marker format, \'cpp\' (default): GNU cpp format, '\ - '\'gfortran5\': modified markers to work around bug in GFortran 5 '\ - 'and above' - parser.add_option('--line-marker-format', metavar='FMT', - choices=['cpp', 'gfortran5'], dest='line_marker_format', - default=defs.line_marker_format, help=msg) - msg = 'maximal line length (default: 132), lines modified by the '\ - 'preprocessor are folded if becoming longer' - parser.add_option('-l', '--line-length', type=int, metavar='LEN', - dest='line_length', default=defs.line_length, help=msg) - msg = 'line folding mode, \'smart\' (default): indentation context '\ - 'and whitespace aware, \'simple\': indentation context aware, '\ - '\'brute\': mechnical folding' - parser.add_option('-f', '--folding-mode', metavar='MODE', - choices=['smart', 'simple', 'brute'], dest='folding_mode', - default=defs.folding_mode, help=msg) - msg = 'suppress line folding' - parser.add_option('-F', '--no-folding', action='store_true', - dest='no_folding', default=defs.no_folding, help=msg) - msg = 'indentation to use for continuation lines (default 4)' - parser.add_option('--indentation', type=int, metavar='IND', - dest='indentation', default=defs.indentation, help=msg) - msg = 'produce fixed format output (any settings for options '\ - '--line-length, --folding-method and --indentation are ignored)' - parser.add_option('--fixed-format', action='store_true', - dest='fixed_format', default=defs.fixed_format, help=msg) - msg = 'character encoding for reading/writing files. Default: \'utf-8\'. '\ - 'Note: reading from stdin and writing to stdout is encoded '\ - 'according to the current locale and is not affected by this setting.' - parser.add_option('--encoding', metavar='ENC', default=defs.encoding, - help=msg) - msg = 'create parent folders of the output file if they do not exist' - parser.add_option('-p', '--create-parents', action='store_true', - dest='create_parent_folder', - default=defs.create_parent_folder, help=msg) - return parser - - -def run_fypp(): - '''Run the Fypp command line tool.''' - options = FyppOptions() - optparser = get_option_parser() - opts, leftover = optparser.parse_args(values=options) - infile = leftover[0] if len(leftover) > 0 else '-' - outfile = leftover[1] if len(leftover) > 1 else '-' - try: - tool = Fypp(opts) - tool.process_file(infile, outfile) - except FyppStopRequest as exc: - sys.stderr.write(_formatted_exception(exc)) - sys.exit(USER_ERROR_EXIT_CODE) - except FyppFatalError as exc: - sys.stderr.write(_formatted_exception(exc)) - sys.exit(ERROR_EXIT_CODE) - - -def linenumdir(linenr, fname, flag=None): - '''Returns a line numbering directive. - - Args: - linenr (int): Line nr (starting with 0). - fname (str): File name. - ''' - if flag is None: - return '# {0} "{1}"\n'.format(linenr + 1, fname) - return '# {0} "{1}" {2}\n'.format(linenr + 1, fname, flag) - - -def _shiftinds(inds, shift): - return [ind + shift for ind in inds] - - -def _open_input_file(inpfile, encoding=None): - try: - inpfp = io.open(inpfile, 'r', encoding=encoding) - except IOError as exc: - msg = "Failed to open file '{0}' for read".format(inpfile) - raise FyppFatalError(msg, cause=exc) - return inpfp - - -def _open_output_file(outfile, encoding=None, create_parents=False): - if create_parents: - parentdir = os.path.abspath(os.path.dirname(outfile)) - if not os.path.exists(parentdir): - try: - os.makedirs(parentdir) - except OSError as exc: - if exc.errno != errno.EEXIST: - msg = "Folder '{0}' can not be created"\ - .format(parentdir) - raise FyppFatalError(msg, cause=exc) - try: - outfp = io.open(outfile, 'w', encoding=encoding) - except IOError as exc: - msg = "Failed to open file '{0}' for write".format(outfile) - raise FyppFatalError(msg, cause=exc) - return outfp - - -def _get_callable_argspec_py2(func): - argspec = inspect.getargspec(func) - varpos = argspec.varargs - varkw = argspec.keywords - args = argspec.args - tuplearg = False - for elem in args: - tuplearg = tuplearg or isinstance(elem, list) - if tuplearg: - msg = 'tuple argument(s) found' - raise FyppFatalError(msg) - defaults = {} - if argspec.defaults is not None: - for ind, default in enumerate(argspec.defaults): - iarg = len(args) - len(argspec.defaults) + ind - defaults[args[iarg]] = default - return args, defaults, varpos, varkw - - -def _get_callable_argspec_py3(func): - sig = inspect.signature(func) - args = [] - defaults = {} - varpos = None - varkw = None - for param in sig.parameters.values(): - if param.kind == param.POSITIONAL_OR_KEYWORD: - args.append(param.name) - if param.default != param.empty: - defaults[param.name] = param.default - elif param.kind == param.VAR_POSITIONAL: - varpos = param.name - elif param.kind == param.VAR_KEYWORD: - varkw = param.name - else: - msg = "argument '{0}' has invalid argument type".format(param.name) - raise FyppFatalError(msg) - return args, defaults, varpos, varkw - - -# Signature objects are available from Python 3.3 (and deprecated from 3.5) - -if sys.version_info[0] >= 3 and sys.version_info[1] >= 3: - _GET_CALLABLE_ARGSPEC = _get_callable_argspec_py3 -else: - _GET_CALLABLE_ARGSPEC = _get_callable_argspec_py2 - - -def _blank_match(match): - size = match.end() - match.start() - return " " * size - - -def _argsplit_fortran(argtxt): - txt = _INLINE_EVAL_REGION_REGEXP.sub(_blank_match, argtxt) - splitpos = [-1] - quote = None - closing_brace_stack = [] - closing_brace = None - for ind, char in enumerate(txt): - if quote: - if char == quote: - quote = None - continue - if char in _QUOTES_FORTRAN: - quote = char - continue - if char in _OPENING_BRACKETS_FORTRAN: - closing_brace_stack.append(closing_brace) - ind = _OPENING_BRACKETS_FORTRAN.index(char) - closing_brace = _CLOSING_BRACKETS_FORTRAN[ind] - continue - if char in _CLOSING_BRACKETS_FORTRAN: - if char == closing_brace: - closing_brace = closing_brace_stack.pop(-1) - continue - else: - msg = "unexpected closing delimiter '{0}' in expression '{1}' "\ - "at position {2}".format(char, argtxt, ind + 1) - raise FyppFatalError(msg) - if not closing_brace and char == _ARGUMENT_SPLIT_CHAR_FORTRAN: - splitpos.append(ind) - if quote or closing_brace: - msg = "open quotes or brackets in expression '{0}'".format(argtxt) - raise FyppFatalError(msg) - splitpos.append(len(txt)) - fragments = [argtxt[start + 1 : end] - for start, end in zip(splitpos, splitpos[1:])] - return fragments - - -def _formatted_exception(exc): - error_header_formstr = '{file}:{line}: ' - error_body_formstr = 'error: {errormsg} [{errorclass}]' - if not isinstance(exc, FyppError): - return error_body_formstr.format( - errormsg=str(exc), errorclass=exc.__class__.__name__) - out = [] - if exc.fname is not None: - if exc.span[1] > exc.span[0] + 1: - line = '{0}-{1}'.format(exc.span[0] + 1, exc.span[1]) - else: - line = '{0}'.format(exc.span[0] + 1) - out.append(error_header_formstr.format(file=exc.fname, line=line)) - out.append(error_body_formstr.format(errormsg=exc.msg, - errorclass=exc.__class__.__name__)) - if exc.cause is not None: - out.append('\n' + _formatted_exception(exc.cause)) - out.append('\n') - return ''.join(out) - - -if __name__ == '__main__': - run_fypp() diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index f373dc2..0175432 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -21,23 +21,16 @@ set(sources-fpp mpifx_scatterv.fpp mpifx_send.fpp) -set(sources-f90-preproc) - -foreach(fppsrc IN LISTS sources-fpp) - string(REGEX REPLACE "\\.fpp" ".f90" f90src ${fppsrc}) - add_custom_command( - OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${f90src} - COMMAND ${FYPP} -I${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc} ${CMAKE_CURRENT_BINARY_DIR}/${f90src} - MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${fppsrc}) - list(APPEND sources-f90-preproc ${CMAKE_CURRENT_BINARY_DIR}/${f90src}) -endforeach() - -# NAG compiler won't compile this files without the '-mismatch' option +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-preproc} PROPERTY COMPILE_FLAGS -mismatch) + set_source_files_properties(SOURCE ${sources-f90} PROPERTY COMPILE_FLAGS -mismatch) endif() -add_library(mpifx ${sources-f90-preproc}) +add_library(mpifx ${sources-f90}) + +target_link_libraries(mpifx PRIVATE MPI::MPI_Fortran) set(BUILD_MOD_DIR ${CMAKE_CURRENT_BINARY_DIR}/include) @@ -45,16 +38,13 @@ set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${BUILD_MOD_DIR} target_include_directories(mpifx PUBLIC $ - $) - -target_include_directories(mpifx PRIVATE ${MPI_Fortran_MODULE_DIR}) -target_link_libraries(mpifx PRIVATE ${MPI_Fortran_LIBRARIES}) + $) install(TARGETS mpifx - EXPORT ${INSTALL_EXPORT_NAME} - ARCHIVE DESTINATION ${INSTALL_LIB_DIR} - LIBRARY DESTINATION ${INSTALL_LIB_DIR}) + EXPORT mpifx-targets + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) if(INSTALL_INCLUDE_FILES) - install(DIRECTORY ${BUILD_MOD_DIR}/ DESTINATION ${INSTALL_MOD_DIR}) + install(DIRECTORY ${BUILD_MOD_DIR}/ DESTINATION ${CMAKE_INSTALL_MODULEDIR}) endif() diff --git a/lib/make.build b/lib/make.build deleted file mode 100644 index 328ef96..0000000 --- a/lib/make.build +++ /dev/null @@ -1,47 +0,0 @@ -############################################################################### -# -# Library makefile -# -# Compiles and links mpifx in the current directory. -# -# Needs the following variables: -# FXX: Fortran 2003 compiler -# FXXOPT: Options for the Fortran 2003 compiler -# LN: Linker -# LNOPT: Linker options -# FYPP: FYPP pre-processor -# FYPPOPT: Options for the FYPP pre-processor. You should use the -I option -# with this directory, if you are invoking the makefile from somewhere -# else. You may also use the -D option to define macros (e.g. DEBUG) -# SRCDIR: Folder where source files are located -# -############################################################################### - -.SUFFIXES: -.SUFFIXES: .f90 .fpp .o - -TARGET = libmpifx.a - -vpath % $(SRCDIR) - -.PHONY: all -all: $(TARGET) - -include $(SRCDIR)/make.deps - -$(TARGET): $(module.o) - ar r $@ $^ - -%.f90: %.fpp - $(FYPP) -I$(SRCDIR) $(FYPPOPT) $< $@ - -%.o: %.f90 - $(FXX) $(FXXOPT) -c $< - -.PHONY: clean -clean: - rm -f *.o - -### Local Variables: -### mode:makefile -### End: diff --git a/lib/make.deps b/lib/make.deps deleted file mode 100644 index 6a29eb7..0000000 --- a/lib/make.deps +++ /dev/null @@ -1,87 +0,0 @@ -.SECONDEXPANSION: - -mpifx_helper.o: $$(_modobj_mpi) $$(_modobj_mpifx_constants_module) -mpifx_helper.o = mpifx_helper.o $($(_modobj_mpi)) $($(_modobj_mpifx_constants_module)) -_modobj_mpifx_helper_module = mpifx_helper.o - -mpifx_recv.o: $$(_modobj_mpifx_common_module) -mpifx_recv.o = mpifx_recv.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_recv_module = mpifx_recv.o - -mpifx_gather.o: $$(_modobj_mpifx_common_module) -mpifx_gather.o = mpifx_gather.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_gather_module = mpifx_gather.o - -mpifx_gatherv.o: $$(_modobj_mpifx_common_module) -mpifx_gatherv.o = mpifx_gatherv.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_gatherv_module = mpifx_gatherv.o - -mpifx_finalize.o: $$(_modobj_mpifx_common_module) -mpifx_finalize.o = mpifx_finalize.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_finalize_module = mpifx_finalize.o - -mpifx_send.o: $$(_modobj_mpifx_common_module) -mpifx_send.o = mpifx_send.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_send_module = mpifx_send.o - -mpifx_allgather.o: $$(_modobj_mpifx_common_module) -mpifx_allgather.o = mpifx_allgather.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allgather_module = mpifx_allgather.o - -mpifx_allgatherv.o: $$(_modobj_mpifx_common_module) -mpifx_allgatherv.o = mpifx_allgatherv.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allgatherv_module = mpifx_allgatherv.o - -mpifx_constants.o: $$(_modobj_mpi) -mpifx_constants.o = mpifx_constants.o $($(_modobj_mpi)) -_modobj_mpifx_constants_module = mpifx_constants.o - -module.o: $$(_modobj_mpifx_send_module) $$(_modobj_mpifx_scatter_module) $$(_modobj_mpifx_scatterv_module) $$(_modobj_mpifx_allgather_module) $$(_modobj_mpifx_allgatherv_module) $$(_modobj_mpifx_finalize_module) $$(_modobj_mpifx_barrier_module) $$(_modobj_mpifx_get_processor_name_module) $$(_modobj_mpifx_abort_module) $$(_modobj_mpifx_init_module) $$(_modobj_mpifx_constants_module) $$(_modobj_mpifx_recv_module) $$(_modobj_mpifx_bcast_module) $$(_modobj_mpifx_gather_module) $$(_modobj_mpifx_gatherv_module) $$(_modobj_mpifx_allreduce_module) $$(_modobj_mpifx_reduce_module) $$(_modobj_mpifx_comm_module) -module.o = module.o $($(_modobj_mpifx_send_module)) $($(_modobj_mpifx_scatter_module)) $($(_modobj_mpifx_scatterv_module)) $($(_modobj_mpifx_allgather_module)) $($(_modobj_mpifx_allgatherv_module)) $($(_modobj_mpifx_finalize_module)) $($(_modobj_mpifx_barrier_module)) $($(_modobj_mpifx_get_processor_name_module)) $($(_modobj_mpifx_abort_module)) $($(_modobj_mpifx_init_module)) $($(_modobj_mpifx_constants_module)) $($(_modobj_mpifx_recv_module)) $($(_modobj_mpifx_bcast_module)) $($(_modobj_mpifx_gather_module)) $($(_modobj_mpifx_gatherv_module)) $($(_modobj_mpifx_allreduce_module)) $($(_modobj_mpifx_reduce_module)) $($(_modobj_mpifx_comm_module)) - -_modobj_libmpifx_module = module.o - -mpifx_allreduce.o: $$(_modobj_mpifx_common_module) -mpifx_allreduce.o = mpifx_allreduce.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_allreduce_module = mpifx_allreduce.o - -mpifx_init.o: $$(_modobj_mpifx_common_module) $$(_modobj_mpifx_constants_module) -mpifx_init.o = mpifx_init.o $($(_modobj_mpifx_common_module)) $($(_modobj_mpifx_constants_module)) -_modobj_mpifx_init_module = mpifx_init.o - -mpifx_common.o: $$(_modobj_mpifx_helper_module) $$(_modobj_mpi) $$(_modobj_mpifx_comm_module) -mpifx_common.o = mpifx_common.o $($(_modobj_mpifx_helper_module)) $($(_modobj_mpi)) $($(_modobj_mpifx_comm_module)) -_modobj_mpifx_common_module = mpifx_common.o - -mpifx_reduce.o: $$(_modobj_mpifx_common_module) -mpifx_reduce.o = mpifx_reduce.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_reduce_module = mpifx_reduce.o - -mpifx_barrier.o: $$(_modobj_mpifx_common_module) -mpifx_barrier.o = mpifx_barrier.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_barrier_module = mpifx_barrier.o - -mpifx_comm.o: $$(_modobj_mpifx_helper_module) $$(_modobj_mpi) -mpifx_comm.o = mpifx_comm.o $($(_modobj_mpifx_helper_module)) $($(_modobj_mpi)) -_modobj_mpifx_comm_module = mpifx_comm.o - -mpifx_scatter.o: $$(_modobj_mpifx_common_module) -mpifx_scatter.o = mpifx_scatter.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_scatter_module = mpifx_scatter.o - -mpifx_scatterv.o: $$(_modobj_mpifx_common_module) -mpifx_scatterv.o = mpifx_scatterv.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_scatterv_module = mpifx_scatterv.o - -mpifx_abort.o: $$(_modobj_mpifx_common_module) -mpifx_abort.o = mpifx_abort.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_abort_module = mpifx_abort.o - -mpifx_bcast.o: $$(_modobj_mpifx_common_module) -mpifx_bcast.o = mpifx_bcast.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_bcast_module = mpifx_bcast.o - -mpifx_get_processor_name.o: $$(_modobj_mpifx_common_module) -mpifx_get_processor_name.o = mpifx_get_processor_name.o $($(_modobj_mpifx_common_module)) -_modobj_mpifx_get_processor_name_module = mpifx_get_processor_name.o - diff --git a/make.arch.template b/make.arch.template deleted file mode 100644 index df379e3..0000000 --- a/make.arch.template +++ /dev/null @@ -1,24 +0,0 @@ -############################################################################ -# Architecture dependent makefile settings -############################################################################ - -# Fortran 2003 compiler -FXX = mpif90 - -# Fortran compiler otions -FXXOPT = - -# Linker -LN = $(FXX) - -# Linker options -LNOPT = - -# M4 interpreter -FYPP = fypp - -# M4 interpreter options -FYPPOPT = "" - -# Where to build the library (ROOT = root of the source distribution) -BUILDDIR = $(ROOT)/_build diff --git a/makefile b/makefile deleted file mode 100644 index 5b06dbe..0000000 --- a/makefile +++ /dev/null @@ -1,32 +0,0 @@ - -ROOT := $(PWD) - -.PHONY: all -all: lib - -include $(ROOT)/make.arch - -.PHONY: lib -lib: - mkdir -p $(BUILDDIR)/lib - $(MAKE) -C $(BUILDDIR)/lib ROOT=$(ROOT) SRCDIR=$(ROOT)/lib \ - FXX="$(FXX)" FXXOPT="$(FXXOPT)" LN="$(LN)" LNOPT="$(LNOPT)" \ - FYPP="$(FYPP)" FYPPOPT="$(FYPPOPT)" -f $(ROOT)/lib/make.build - -.PHONY: install -install: lib - mkdir -p $(INSTALLDIR)/lib - cp $(BUILDDIR)/lib/*.a $(INSTALLDIR)/lib - mkdir -p $(INSTALLDIR)/include - cp $(BUILDDIR)/lib/*.mod $(INSTALLDIR)/include - -.PHONY: test -test: lib - mkdir -p $(BUILDDIR)/test - $(MAKE) -C $(BUILDDIR)/test ROOT=$(ROOT) BUILDROOT=$(BUILDDIR) \ - -f $(ROOT)/test/make.build - - -.PHONY: distclean -distclean: - rm -rf $(BUILDDIR) diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index efaf04f..33983d7 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -12,5 +12,5 @@ set(targets foreach(target IN LISTS targets) add_executable(${target} ${target}.f90) - target_link_libraries(${target} mpifx ${MPI_Fortran_LIBRARIES}) + target_link_libraries(${target} MpiFx) endforeach() 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/make.build b/test/make.build deleted file mode 100644 index 4a0f8ef..0000000 --- a/test/make.build +++ /dev/null @@ -1,77 +0,0 @@ -############################################################################ -# -# Makefile for building some example programs -# -# Needs as variable: -# ROOT Source root directory -# BUILDROOT Build root directory -# -# The mpifx library must be already built in $(BUILDROOT)/lib -# -############################################################################ - - -############################################################################ -# Building some test/example programs. -############################################################################ - -.SUFFIXES: -.SUFFIXES: .f90 .o - -TARGETS = test_bcast test_send_recv test_comm_split test_reduce \ - test_allreduce test_gather test_allgather test_scatter \ - test_scatterv - -all: $(TARGETS) - -MPIFX_LIBDIR = $(BUILDROOT)/lib -MPIFX_INCDIR = $(BUILDROOT)/lib - -include $(ROOT)/make.arch - -# Directory where library source can be found -SRCDIR = $(ROOT)/test - -vpath % $(SRCDIR) - -%.o: %.f90 - $(FXX) $(FXXOPT) -I$(MPIFX_INCDIR) -c $< - -# Linking rules for targets -define link-target -$(LN) $(LNOPT) -o $@ $^ -L$(MPIFX_LIBDIR) -lmpifx -endef - -.PHONY: clean -clean: - rm -f *.mod *.o _* - - -include $(SRCDIR)/make.deps - -test_bcast: $(test_bcast.o) - $(link-target) - -test_send_recv: $(test_send_recv.o) - $(link-target) - -test_comm_split: $(test_comm_split.o) - $(link-target) - -test_reduce: $(test_reduce.o) - $(link-target) - -test_allreduce: $(test_allreduce.o) - $(link-target) - -test_gather: $(test_gather.o) - $(link-target) - -test_allgather: $(test_allgather.o) - $(link-target) - -test_scatter: $(test_scatter.o) - $(link-target) - -test_scatterv: $(test_scatterv.o) - $(link-target) diff --git a/test/make.deps b/test/make.deps deleted file mode 100644 index e2d11be..0000000 --- a/test/make.deps +++ /dev/null @@ -1,35 +0,0 @@ -.SECONDEXPANSION: - -test_allgather.o: $$(_modobj_libmpifx_module) -test_allgather.o = test_allgather.o $($(_modobj_libmpifx_module)) - -test_allgatherv.o: $$(_modobj_libmpifx_module) -test_allgatherv.o = test_allgatherv.o $($(_modobj_libmpifx_module)) - -test_gather.o: $$(_modobj_libmpifx_module) -test_gather.o = test_gather.o $($(_modobj_libmpifx_module)) - -test_gatherv.o: $$(_modobj_libmpifx_module) -test_gatherv.o = test_gatherv.o $($(_modobj_libmpifx_module)) - -test_send_recv.o: $$(_modobj_libmpifx_module) -test_send_recv.o = test_send_recv.o $($(_modobj_libmpifx_module)) - -test_bcast.o: $$(_modobj_libmpifx_module) -test_bcast.o = test_bcast.o $($(_modobj_libmpifx_module)) - -test_scatter.o: $$(_modobj_libmpifx_module) -test_scatter.o = test_scatter.o $($(_modobj_libmpifx_module)) - -test_scatterv.o: $$(_modobj_libmpifx_module) -test_scatterv.o = test_scatterv.o $($(_modobj_libmpifx_module)) - -test_comm_split.o: $$(_modobj_libmpifx_module) -test_comm_split.o = test_comm_split.o $($(_modobj_libmpifx_module)) - -test_reduce.o: $$(_modobj_libmpifx_module) -test_reduce.o = test_reduce.o $($(_modobj_libmpifx_module)) - -test_allreduce.o: $$(_modobj_libmpifx_module) -test_allreduce.o = test_allreduce.o $($(_modobj_libmpifx_module)) - diff --git a/utils/cr_makedep b/utils/cr_makedep deleted file mode 100755 index cb52d73..0000000 --- a/utils/cr_makedep +++ /dev/null @@ -1,394 +0,0 @@ -#!/usr/bin/env python -############################################################################### -# -# Copyright (c) 2013, Balint 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. -# -############################################################################### -from __future__ import print_function -import argparse -import re -import os -import copy - -DESCRIPTION = """Creates dependency information for the GNU Make system by -analyzing Fortran 90+ source files. - -It searches the source files in the given directory for module inclusions and -module definitions (via the 'use' and 'module' statements). In every directory -it creates a file 'Makefile.dep' which can be included by the actual makefile. -If the source files contain CPP conditionals (#if, #ifdef, #else, -#endif), they will be included in the dependency file, so that preprocessing -the dependency file with CPP will give the correct dependencies. -""" - -# Patterns for branch constructs: #if*, #else, #endif -PAT_IF = re.compile(r"^[ \t]*#[ \t]*if(?P(?:n?def)?[ \t]+.*)$", - re.MULTILINE) -PAT_ELSE = re.compile(r"^[ \t]*#[ \t]*else[ \t]*$", re.MULTILINE) -PAT_ENDIF = re.compile(r"^[ \t]*#[ \t]*endif\s*$", re.MULTILINE) - -# Patterns for other constructs: #include, use, module -PAT_INCLUDE = re.compile(r"""^[ \t]*\#[ \t]*include\s+ - (?:'(?P[^']+)' - |\"(?P[^\"]+)\") - """, re.MULTILINE | re.VERBOSE) - -PAT_USE = re.compile(r"^[ \t]*use[ \t]+(?P[^ \s,]*)", - re.MULTILINE | re.IGNORECASE) - -PAT_MODULE = re.compile(r"^[ \t]*module[ \t]+(?P\S+)[ \t]*$", - re.MULTILINE | re.IGNORECASE) - -PAT_INCLUDE2 = re.compile(r"^[ \t]*include\s*['\"(](?P[^'\")]+)['\")]", - re.MULTILINE | re.IGNORECASE) - -# List of all patterns -PATTERNS = ( PAT_IF, PAT_ELSE, PAT_ENDIF, PAT_INCLUDE, PAT_USE, PAT_MODULE, - PAT_INCLUDE2 ) - -# Dependency information types -DEP_MODULE = 0 -DEP_INCLUDE = 1 - -# Definition types -DFN_MODULE = 0 - -# Pattern to select files to process: -PAT_FILE = re.compile(r"\.f90$|\.h$|\.inc|\.fpp$", re.IGNORECASE) - -# Extensions to be considered Fortran source files -FORTRAN_EXTENSIONS = (".f90", ".f", ".fpp") - -# Name of the dependency output -DEPFILE = "Makefile.dep" - -class MakedepException(Exception): - pass - - -class BranchBlock(object): - """Contains information on a block which may contain dependency information - and a branch point""" - - def __init__(self): - """Initialises a BranchBlock""" - self._dependencies = set() # Dependencies - self._definitions = set() # Defined entities - self._condition = "" # Condition for the branch point - self._truechild = None # True block of the branch - self._falsechild = None # False block of the branch - self._hasbranch = False # If current block contains a branch - - - def add_dependency(self, dep, deptype): - """Adds a dependency to the current block - dep -- name of the dependency - deptype -- type of the dependency - """ - self._dependencies.add((dep, deptype)) - - - def add_definition(self, dfn, dfntype): - """Adds a dependency to the current block - dfn -- name of the definition - deptype -- type of the definition - """ - self._definitions.add((dfn, dfntype)) - - - def add_branch(self, condition, true, false): - """Adds a branch to the current block - condition -- Branching condition - true -- True block of the branch - false -- False block of the branch - """ - # Make sure, all branches are proper objects - true = true or BranchBlock() - false = false or BranchBlock() - - if self._hasbranch: - # We have a branch point already, add new branch to them - if self._condition == condition: - self._truechild.extendBlock(true) - self._falsechild.extendBlock(false) - else: - self._truechild.add_branch(condition, true, false) - self._falsechild.add_branch(condition, true, false) - else: - # No branch point yet: branch point added to the current block - self._hasbranch = True - self._condition = condition - self._truechild = copy.deepcopy(true) - self._falsechild = copy.deepcopy(false) - - - def extend_block(self, block): - """Extends a block with the content of an other one. - block -- Contains the information to add - """ - self._dependencies.update(block._dependencies) - self._definitions.update(block._definitions) - if block._hasbranch: - self.add_branch(block._condition, block._truechild, - block._falsechild) - - - def hasbranch(self): - """Returns flag, if current block contains a branch or not""" - return self._hasbranch - - - def has_deps_or_defs(self): - """Flags, if current block contains any dependencies or definitions""" - return (len(self._dependencies) != 0 or len(self._definitions) != 0) - - - def write_tree(self, fp, fbase, fext, fsrc): - """Prints the dependency tree in the appropriate format - fp -- pointer to an open file - fbase -- base name of the processed file - fext -- extension of the processed file - fsrc -- flags if processed file was a fortran file or not - (A more elegant implementation would do this with a writer class...) - """ - self._write_tree_recursive(fp, [], [], fbase, fext, fsrc) - - - def _write_tree_recursive(self, fp, deps, defs, fbase, fext, fsrc): - """Working horse for the write_tree routine - fp: file pointer - deps: Dependencies so far - defs: Definitions so far - fbase: base name of the processed file - fext: extension of the processed file - fsrc: flags if processed file was a fortran source file - """ - - newdeps = deps + list(self._dependencies) - newdefs = defs + list(self._definitions) - - if self._hasbranch: - # We have a branch point, dive into the true and false branch - fp.write("#if{}\n".format(self._condition)) - self._truechild._write_tree_recursive(fp, newdeps, newdefs, fbase, - fext, fsrc) - fp.write("#else\n") - self._falsechild._write_tree_recursive(fp, newdeps, newdefs, fbase, - fext, fsrc) - fp.write("#endif\n") - else: - # No further branch points: write all dependencies in order - filedeps = [] - vardeps = [] - for (depname, deptype) in newdeps: - if deptype == DEP_MODULE: - filedeps.append("$$({0}{1})".format("_modobj_", depname)) - vardeps.append("$($({0}{1}))".format("_modobj_", depname)) - else: - filedeps.append(depname) - vardeps.append("$({0})".format(depname)) - if fsrc: - fp.write("{0}.o: ".format(fbase)) - if filedeps: - fp.write(" ".join(filedeps)) - fp.write("\n") - fp.write("{0}.o = {0}.o ".format(fbase)) - if vardeps: - fp.write(" ".join(vardeps)) - fp.write("\n") - else: - if filedeps: - fp.write("{0}{1}: ".format(fbase, fext)) - fp.write(" ".join(filedeps) + "\n") - fp.write("{0}{1} = ".format(fbase, fext)) - if vardeps: - fp.write(" ".join(vardeps)) - fp.write("\n") - - # Write definitions: - for (dfnname, dfntype) in newdefs: - if dfntype == DFN_MODULE: - fp.write("{0}{1} = {2}.o\n".format("_modobj_", dfnname, - fbase)) - - -def build_dependency_tree(txt): - """Creates a dependency tree for the given text""" - - end = len(txt) - matches = [ pat.search(txt) for pat in PATTERNS ] - starts = [] - for match in matches: - if match: - starts.append(match.start()) - else: - starts.append(end) - (itype, node) = build_dependency_recursive(txt, matches, starts) - return node - - - -def nextmatch(txt, matches, starts, itype): - # Helper function for build_dependency_recursive, updating matches and - # starts by replacing the entries for itype with the next occurance. - - if matches[itype] == None: - raise MakedepException("Invalid nesting of blocks " - "(probably unclosed #if* block)") - match = PATTERNS[itype].search(txt, matches[itype].end()) - matches[itype] = match - if match: - starts[itype] = match.start() - else: - starts[itype] = len(txt) - - -def build_dependency_recursive(txt, matches, starts): - """Working function for the build_dependency_tree routine. - txt -- text to parse - matches -- last match for each pattern in PATTERNS - starts -- starting position of the last matches (len(txt) if no match) - return -- (itype, node), where itype is the type of the closing block - and node is the tree built. - """ - - block = BranchBlock() - end = len(txt) - firstpos = min(starts) - itype = -1 - - # Loop as long we did not reach the end of the text - while firstpos < end: - - # get entry type and match object for the first pttern match - itype = starts.index(firstpos) - match = matches[itype] - - if itype == 0: - # Branch opening (#ifdef) - condition = match.group("cond") - nextmatch(txt, matches, starts, itype) - (itype, ifbranch) = build_dependency_recursive(txt, matches, starts) - if itype == 1: - # If branch ended with #else -> parse the else branch as well - nextmatch(txt, matches, starts, itype) - (itype, elsebranch) = build_dependency_recursive(txt, matches, - starts) - else: - elsebranch = None - # Sanity check: #if must be closed by #endif - if itype != 2: - raise MakedepException("ERROR, #else must be terminted by " - "#endif") - # if any of the two branches contains usefull info, add the branch - # to the current block - if ifbranch or elsebranch: - block.add_branch(condition, ifbranch, elsebranch) - elif itype == 1 or itype == 2: - # block closing #else or #endif found -> escape to higher level - break - elif itype == 3: - # #include found - groups = match.groups() - name = groups[0] - if not name: - name = groups[1] - block.add_dependency(name, DEP_INCLUDE) - elif itype == 4: - # module found - block.add_dependency(match.group("mod").lower(), DEP_MODULE) - elif itype == 5: - # module defintion found - block.add_definition(match.group("mod").lower(), DFN_MODULE) - elif itype == 6: - # include with ' or " or () - block.add_dependency(match.group("name"), DEP_INCLUDE) - else: - raise MakedepException("Unknown itype: {:d}".format(itype)) - - # Get next occurance for processed entry - nextmatch(txt, matches, starts, itype) - firstpos = min(starts) - - # Pass block back, if it contains usefull info - if block.has_deps_or_defs() or block.hasbranch(): - return (itype, block) - else: - return (itype, None) - - -def write_depfile(fp, sources): - """Writes dependency file. - fp -- File descriptor for file to write to. - sources -- Fortran source files to investigate - """ - - fp.write(".SECONDEXPANSION:\n\n") - for source in sources: - print("Processing: {}".format(source)) - fpsource = open(source, "r") - txt = fpsource.read() - fpsource.close() - tree = build_dependency_tree(txt) - if tree: - fbase, fext = os.path.splitext(os.path.basename(source)) - fextlow = fext.lower() - fsrc = fextlow in FORTRAN_EXTENSIONS - tree.write_tree(fp, fbase, fext, fsrc) - fp.write("\n") - - - -def main(): - """Main procedure""" - - parser = argparse.ArgumentParser(description=DESCRIPTION) - parser.add_argument( - 'dirnames', metavar='DIR', nargs='*', default=["."], - help="Directory in which dependency file should be created " - "(default: '.')") - - args = parser.parse_args() - - for dirname in args.dirnames: - outname = os.path.join(dirname, DEPFILE) - print("Creating:", outname) - fp = open(outname, "w") - fnames = [ os.path.join(dirname, fname) - for fname in os.listdir(dirname) - if PAT_FILE.search(fname) ] - write_depfile(fp, fnames) - fp.close() - - -if __name__ == "__main__": - main() - - -### Local Variables: -### mode:python -### End: 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@ From 79d8ca32ffbe1426729874a0596716c4a190e998 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Fri, 9 Oct 2020 17:37:50 +0200 Subject: [PATCH 71/72] Fix minor issues --- .travis.yml | 8 +++++--- CMakeLists.txt | 11 +++++++---- README.rst | 4 ++-- config.cmake | 4 ++-- 4 files changed, 16 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index ba17c87..4b20676 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,13 +22,15 @@ install: script: - > - FC=gfortran cmake -DBUILD_SHARED_LIBS=${BUILD_SHARED_LIBS} -B _build . + 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}/_build/install:${CMAKE_PREFIX_PATH}" + CMAKE_PREFIX_PATH="${PWD}/_install:${CMAKE_PREFIX_PATH}" ./test/integration/cmake/runtest.sh _build_cmake - > - PKG_CONFIG_PATH="${PWD}/_build/install/lib/pkgconfig:${PKG_CONFIG_PATH}" + 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 index 44a313d..21836c8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,11 +1,14 @@ cmake_minimum_required(VERSION 3.16) -set(CMAKE_MODULE_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake) +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) -include(MpiFxUtils) setup_build_type() # @@ -20,6 +23,8 @@ endif() # # Build instructions # +include(GNUInstallDirs) + add_subdirectory(lib) if(NOT BUILD_EXPORTED_TARGETS_ONLY) add_subdirectory(test) @@ -37,7 +42,6 @@ install(EXPORT mpifx-targets NAMESPACE MpiFx:: DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/mpifx") -include(CMakePackageConfigHelpers) configure_package_config_file( ${CMAKE_CURRENT_SOURCE_DIR}/utils/export/mpifx-config.cmake.in ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config.cmake @@ -53,7 +57,6 @@ install( ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config-version.cmake DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/mpifx) -include(GNUInstallDirs) GNUInstallDirs_get_absolute_install_dir(CMAKE_INSTALL_FULL_MODULEDIR CMAKE_INSTALL_MODULEDIR) get_pkgconfig_params(PKGCONFIG_REQUIRES PKGCONFIG_LIBS PKGCONFIG_LIBS_PRIVATE PKGCONFIG_C_FLAGS) diff --git a/README.rst b/README.rst index 484d74e..e40d884 100644 --- a/README.rst +++ b/README.rst @@ -23,7 +23,7 @@ Prerequisites * MPI-library and wrappers for your compiler -* `Fypp preprocessor `_. +* `Fypp preprocessor `_ Building and installing the library @@ -31,7 +31,7 @@ Building and installing the library The library can be built and installed with the usual CMake-workflow:: - FC=gfortran cmake -B _build + FC=gfortran cmake -B _build -DCMAKE_INSTALL_PREFIX=$HOME/opt/mpifx cmake --build _build cmake --install _build diff --git a/config.cmake b/config.cmake index 28d2389..c5e48e7 100644 --- a/config.cmake +++ b/config.cmake @@ -25,10 +25,10 @@ option(BUILD_SHARED_LIBS "Whether the library should be a shared one" FALSE) option(INSTALL_INCLUDE_FILES "Whether include / module files should be installed" TRUE) -set(CMAKE_INSTALL_PREFIX "${CMAKE_BINARY_DIR}/install" CACHE STRING +set(CMAKE_INSTALL_PREFIX "${CMAKE_BINARY_DIR}/_install" CACHE STRING "Directory to install the compiled code into") -set(CMAKE_INSTALL_LIBDIR "lib" CACHE PATH "Installation directory for libraries") +#set(CMAKE_INSTALL_LIBDIR "lib" CACHE PATH "Installation directory for libraries") set(CMAKE_INSTALL_INCLUDEDIR "include/mpifx" CACHE PATH "Installation directory for header and include files") From 10ac0b4ae81f7508efbddcc9fb2ffe6303eacdce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Tue, 13 Oct 2020 16:14:54 +0200 Subject: [PATCH 72/72] Use standard GNU installation paths --- CMakeLists.txt | 2 -- cmake/MpiFxUtils.cmake | 2 +- config.cmake | 10 ++++------ lib/CMakeLists.txt | 4 ++-- 4 files changed, 7 insertions(+), 11 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 21836c8..86be1ec 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -57,8 +57,6 @@ install( ${CMAKE_CURRENT_BINARY_DIR}/cmake/mpifx-config-version.cmake DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/mpifx) -GNUInstallDirs_get_absolute_install_dir(CMAKE_INSTALL_FULL_MODULEDIR CMAKE_INSTALL_MODULEDIR) - 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) diff --git a/cmake/MpiFxUtils.cmake b/cmake/MpiFxUtils.cmake index 7fa02b3..e94f5a7 100644 --- a/cmake/MpiFxUtils.cmake +++ b/cmake/MpiFxUtils.cmake @@ -38,7 +38,7 @@ function(get_pkgconfig_params pkgconfig_requires pkgconfig_libs pkgconfig_libs_p set(_pkgconfig_libs_private "${CMAKE_EXE_LINKER_FLAGS}") - set(_pkgconfig_c_flags "-I${CMAKE_INSTALL_FULL_MODULEDIR}") + 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) diff --git a/config.cmake b/config.cmake index c5e48e7..4cd2602 100644 --- a/config.cmake +++ b/config.cmake @@ -28,10 +28,8 @@ option(INSTALL_INCLUDE_FILES "Whether include / module files should be installed set(CMAKE_INSTALL_PREFIX "${CMAKE_BINARY_DIR}/_install" CACHE STRING "Directory to install the compiled code into") -#set(CMAKE_INSTALL_LIBDIR "lib" CACHE PATH "Installation directory for libraries") +set(INSTALL_INCLUDEDIR "mpifx" CACHE PATH + "Installation directory for header and include files (within standard include folder)") -set(CMAKE_INSTALL_INCLUDEDIR "include/mpifx" CACHE PATH - "Installation directory for header and include files") - -set(CMAKE_INSTALL_MODULEDIR "${CMAKE_INSTALL_INCLUDEDIR}/modfiles" CACHE PATH - "Installation directory for Fortran module files") +set(INSTALL_MODULEDIR "${INSTALL_INCLUDEDIR}/modfiles" CACHE PATH + "Installation directory for Fortran module files (within standard include folder)") diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index 0175432..8fd9245 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -38,7 +38,7 @@ set_target_properties(mpifx PROPERTIES Fortran_MODULE_DIRECTORY ${BUILD_MOD_DIR} target_include_directories(mpifx PUBLIC $ - $) + $) install(TARGETS mpifx EXPORT mpifx-targets @@ -46,5 +46,5 @@ install(TARGETS mpifx LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) if(INSTALL_INCLUDE_FILES) - install(DIRECTORY ${BUILD_MOD_DIR}/ DESTINATION ${CMAKE_INSTALL_MODULEDIR}) + install(DIRECTORY ${BUILD_MOD_DIR}/ DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/${INSTALL_MODULEDIR}) endif()