From b17c2c08849bcbb1ae7d8ac54b3018501707ae8c Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Tue, 14 May 2024 11:07:19 +0200 Subject: [PATCH 1/2] feat: add MPI wrappers --- example/use_mpi.f90 | 11 ++ fpm.toml | 7 +- src/sourcery/sourcery_mpi_parallelism_s.f90 | 38 +++++++ .../sourcery_native_parallelism_s.f90 | 29 +++++ src/sourcery/sourcery_parallelism_m.f90 | 104 ++++++++++++++++++ 5 files changed, 188 insertions(+), 1 deletion(-) create mode 100644 example/use_mpi.f90 create mode 100644 src/sourcery/sourcery_mpi_parallelism_s.f90 create mode 100644 src/sourcery/sourcery_native_parallelism_s.f90 create mode 100644 src/sourcery/sourcery_parallelism_m.f90 diff --git a/example/use_mpi.f90 b/example/use_mpi.f90 new file mode 100644 index 00000000..5030978f --- /dev/null +++ b/example/use_mpi.f90 @@ -0,0 +1,11 @@ +program mpi_hello_world + !! Use MPI wrappers analogous to Fortran's native parallel features + use parallelism_m, only : mpi_t, init_, finalize_, this_image_, num_images_ + implicit none + + type(mpi_t) mpi + + call init_(mpi) + print *,"Hello from image ",this_image_()," of ",num_images_() + call finalize_(mpi) +end program diff --git a/fpm.toml b/fpm.toml index ef3414ea..566f4b39 100644 --- a/fpm.toml +++ b/fpm.toml @@ -1,5 +1,5 @@ name = "sourcery" -version = "4.8.0" +version = "4.8.1" license = "BSD" author = ["Damian Rouson"] maintainer = "damian@sourceryinstitute.org" @@ -7,3 +7,8 @@ copyright = "2020-2024 Sourcery Institute" [dependencies] assert = {git = "https://github.com/sourceryinstitute/assert", tag = "1.6.0"} +mpi = "*" + +[fortran] +implicit-typing = true +implicit-external = true diff --git a/src/sourcery/sourcery_mpi_parallelism_s.f90 b/src/sourcery/sourcery_mpi_parallelism_s.f90 new file mode 100644 index 00000000..e58b3f5a --- /dev/null +++ b/src/sourcery/sourcery_mpi_parallelism_s.f90 @@ -0,0 +1,38 @@ +submodule(parallelism_m) mpi_parallelism_s + !! Define wrappers for Message Passing Interface (MPI) procedures + use mpi_f08 + use iso_fortran_env, only : error_unit + implicit none + +contains + + module procedure error_stop_mpi_integer + call MPI_Abort(mpi_comm_world, code) + end procedure + + module procedure error_stop_mpi_character + write(error_unit,*) code + call MPI_Abort(mpi_comm_world, errorcode=1) + end procedure + + module procedure init_mpi + integer ierr + call mpi_init(ierr) + end procedure + + module procedure finalize_mpi + call mpi_finalize() + end procedure + + module procedure this_image_mpi + integer rank, ierr + call mpi_comm_rank(mpi_comm_world, rank, ierr) + this_image_mpi = rank + 1 + end procedure + + module procedure num_images_mpi + integer ierr + call mpi_comm_size(mpi_comm_world, num_images_mpi, ierr) + end procedure + +end submodule mpi_parallelism_s diff --git a/src/sourcery/sourcery_native_parallelism_s.f90 b/src/sourcery/sourcery_native_parallelism_s.f90 new file mode 100644 index 00000000..a2a9e2b0 --- /dev/null +++ b/src/sourcery/sourcery_native_parallelism_s.f90 @@ -0,0 +1,29 @@ +submodule(parallelism_m) native_parallelism_s + !! Define wrappers for Fortan's native parallel programming model + implicit none + +contains + + module procedure error_stop_native_integer + error stop code + end procedure + + module procedure error_stop_native_character + error stop code + end procedure + + module procedure init_native + end procedure + + module procedure finalize_native + end procedure + + module procedure this_image_native + this_image_native = this_image() + end procedure + + module procedure num_images_native + num_images_native = num_images() + end procedure + +end submodule native_parallelism_s diff --git a/src/sourcery/sourcery_parallelism_m.f90 b/src/sourcery/sourcery_parallelism_m.f90 new file mode 100644 index 00000000..e4fb5d43 --- /dev/null +++ b/src/sourcery/sourcery_parallelism_m.f90 @@ -0,0 +1,104 @@ +module parallelism_m + !! Use compile-time polymophism to select wrappers for native or alternative parallel progromming models + implicit none + + private + public :: mpi_t ! alternative programming models + + public :: error_stop_ ! execute error stop or print stop code, invoke MPI_Finalize, and invoke MPI_Abort + !public :: co_broadcast_ ! call co_broadcast or MPI_Bcast + !public :: co_sum_ ! call co_sum or MPI_Reduce + !public :: co_min_ ! call co_min or MPI_Reduce + !public :: co_max_ ! call co_max or MPI_Reduce + !public :: co_reduce_ ! call co_reduce or MPI_Reduce + public :: init_ ! do nothing or invoke MPI_Init + public :: finalize_ ! do nothing or a invoke MPI_Finalize + public :: num_images_ ! invoke num_images() or call MPI_Comm_Size + !public :: sync_all_ ! execute sync all or invoke MPI_Barrier + !public :: stop_ ! execute stop or print stop code, invoke MPI_Finalize, and then execute stop + public :: this_image_ ! invoke this_image() or call MPI_Comm_Rank + + type mpi_t + end type + + interface error_stop_ + + module subroutine error_stop_native_integer(code) + implicit none + integer, intent(in) :: code + end subroutine + + module subroutine error_stop_mpi_integer(mpi, code) + implicit none + type(mpi_t) mpi + integer, intent(in) :: code + end subroutine + + module subroutine error_stop_native_character(code) + implicit none + character(len=*), intent(in) :: code + end subroutine + + module subroutine error_stop_mpi_character(mpi, code) + implicit none + type(mpi_t) mpi + character(len=*), intent(in) :: code + end subroutine + + end interface + + interface init_ + + module subroutine init_native() + implicit none + end subroutine + + module subroutine init_mpi(mpi) + implicit none + type(mpi_t) mpi + end subroutine + + end interface + + interface finalize_ + + module subroutine finalize_native() + implicit none + end subroutine + + module subroutine finalize_mpi(mpi) + implicit none + type(mpi_t) mpi + end subroutine + + end interface + + interface this_image_ + + integer module function this_image_native() + implicit none + end function + + integer module function this_image_mpi(mpi) + implicit none + type(mpi_t) mpi + end function + + end interface + + interface num_images_ + + integer module function num_images_native() + implicit none + end function + + integer module function num_images_mpi(mpi) + implicit none + type(mpi_t) mpi + end function + + end interface + + ! ... + +end module parallelism_m From a0819538c3ff6af2da0dea407588f1c22d1a6db2 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Fri, 24 May 2024 16:05:02 -0700 Subject: [PATCH 2/2] WIP: USE_MPI macro toggles MPI usage This commit breaks non-MPI builds. To build and test with MPI, run fpm test \ --compiler mpifort \ --runner "mpiexec -n 1" \ --flag "-DUSE_MPI" \ --profile release --- test/command_line_test.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/test/command_line_test.F90 b/test/command_line_test.F90 index 01b80c9e..805afba1 100644 --- a/test/command_line_test.F90 +++ b/test/command_line_test.F90 @@ -56,7 +56,11 @@ function check_flag_value() result(test_passes) character(len=132) command_message call execute_command_line( & +#ifdef USE_MPI + command = "fpm run --example get-flag-value --compiler mpifort --runner 'mpiexec -n 1' -- --input-file some_file_name", & +#else command = "fpm run --example get-flag-value -- --input-file some_file_name", & +#endif wait = .true., exitstat = exit_status, cmdstat = command_status, cmdmsg = command_message & ) test_passes = exit_status == 0 @@ -68,7 +72,11 @@ function handle_missing_flag_value() result(test_passes) character(len=132) command_message call execute_command_line( & +#ifdef USE_MPI + command = "fpm run --example handle-missing-flag --compiler mpifort --runner 'mpiexec -n 1' -- --empty-flag", & +#else command = "fpm run --example handle-missing-flag -- --empty-flag", & +#endif wait = .true., exitstat = exit_status, cmdstat = command_status, cmdmsg = command_message & ) test_passes = exit_status == 0 @@ -80,7 +88,11 @@ function check_command_line_argument() result(test_passes) character(len=132) command_message call execute_command_line( & +#ifdef USE_MPI + command = "fpm run --example check-command-line-argument --compiler mpifort --runner 'mpiexec -n 1' -- --some-argument", & +#else command = "fpm run --example check-command-line-argument -- --some-argument", & +#endif wait = .true., exitstat = exit_status, cmdstat = command_status, cmdmsg = command_message & ) test_passes = exit_status == 0