Feature: Add MPI wrappers

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

fpm.toml

@@ -1,9 +1,14 @@
 name = "sourcery"
-version = "4.8.0"
+version = "4.8.1"
 license = "BSD"
 author = ["Damian Rouson"]
 maintainer = "[email protected]"
 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

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

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

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

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