Skip to content

Adding MPI parallelization in the coupling with WRF #30

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
pedro-jm merged 3 commits into from
Apr 16, 2026
Merged

Adding MPI parallelization in the coupling with WRF #30

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
c5d4210
Pass MPI communicator from WRF to fire model
pedro-jm Apr 13, 2026
ab21adc
Supports MPI parallelization with WRF
pedro-jm Apr 14, 2026
d44126a
Better treatment fuel left after ignition
pedro-jm Apr 15, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 15 additions & 2 deletions driver/initialize_mod.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -149,19 +149,30 @@ subroutine Init_fire_state_within_wrf (state, config_flags, &
kfds, kfde, kfms, kfme, kfps, kfpe, &
kfts, kfte, ide, jde, dx, dy, sr_x, sr_y, &
map_proj, cen_lat, cen_lon, truelat1, truelat2, stand_lon, &
nfuel_cat, zsf, dzdxf, dzdyf)
nfuel_cat, zsf, dzdxf, dzdyf, communicator)

#ifdef DM_PARALLEL
use mpi
#endif
implicit none

type (state_fire_t), intent (in out) :: state
type (namelist_t), intent (in) :: config_flags
integer, intent (in) :: ifds, ifde, ifms, ifme, ifps, ifpe, &
jfds, jfde, jfms, jfme, jfps, jfpe, &
kfds, kfde, kfms, kfme, kfps, kfpe, &
kfts, kfte, map_proj, sr_x, sr_y, ide, jde
kfts, kfte, map_proj, sr_x, sr_y, ide, jde, communicator
real :: dx, dy, cen_lat, cen_lon, truelat1, truelat2, stand_lon
real, dimension(ifms:ifme, jfms:jfme), intent (in) :: nfuel_cat, zsf, dzdxf, dzdyf

logical, parameter :: DEBUG_LOCAL = .false.


if (DEBUG_LOCAL) call Print_message (' Entering subroutine Init_fire_state_within_wrf...')

#ifdef DM_PARALLEL
call state%Set_mpi_comm_cfbm (communicator)
#endif

call state%Initialization (config_flags, &
ifds = ifds, ifde = ifde, ifms = ifms, ifme = ifme, ifps = ifps, ifpe = ifpe, &
Expand All @@ -174,6 +185,8 @@ subroutine Init_fire_state_within_wrf (state, config_flags, &

call Init_fire_components (state, config_flags)

if (DEBUG_LOCAL) call Print_message (' Leaving subroutine Init_fire_state_within_wrf...')

end subroutine Init_fire_state_within_wrf

end module initialize_mod
5 changes: 5 additions & 0 deletions physics/fire_model_mod.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -147,6 +147,11 @@ subroutine Advance_fire_model (config_flags, grid)
end do
!$OMP END PARALLEL DO

#ifdef DM_PARALLEL
call Do_halo_exchange_with_corners (grid%tign_g, ifms, ifme, jfms, jfme, grid%ifps, grid%ifpe, grid%jfps, grid%jfpe, N_POINTS_IN_HALO, grid%cart_comm)
call Do_halo_exchange_with_corners (grid%lfn, ifms, ifme, jfms, jfme, grid%ifps, grid%ifpe, grid%jfps, grid%jfpe, N_POINTS_IN_HALO, grid%cart_comm)
#endif

if (DEBUG_LOCAL) call Print_message ('calling Calc_fuel_left...')
!$OMP PARALLEL DO &
!$OMP PRIVATE (ij, ifts, ifte, jfts, jfte)
Expand Down
126 changes: 118 additions & 8 deletions share/mpi_mod.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,14 @@ module mpi_mod
private

public :: Calc_tasks_in_x_and_y, Calc_patch_dims, Gather_var2d, Do_halo_exchange, Do_halo_exchange_with_corners, &
Max_across_mpi_tasks, Sum_across_mpi_tasks, Distribute_var2d, Min_across_mpi_tasks, Convert_mpi_comm_to_f08
Max_across_mpi_tasks, Sum_across_mpi_tasks, Distribute_var2d, Min_across_mpi_tasks, Convert_mpi_comm_to_f08, &
Print_cart_info, topology_dim_order

! --- Topology Ordering Flag ---
! 0 = Default (Fortran order: X is Dim 0, Y is Dim 1)
! 1 = External (C/C++ order: Y is Dim 0, X is Dim 1)
integer :: topology_dim_order = 0
! ------------------------------

contains

Expand Down Expand Up @@ -218,8 +225,11 @@ subroutine Do_halo_exchange (patch, ims, ime, jms, jme, ips, ipe, jps, jpe, ngho
integer :: rank, i, j, k
integer, dimension(2) :: coords

! New variables to handle the topology mapping
integer :: dim_x, dim_y

#ifdef DM_PARALLEL

call MPI_Comm_rank(cart_comm, rank, ierr)
call MPI_Cart_coords(cart_comm, rank, 2, coords, ierr)

Expand All @@ -228,9 +238,23 @@ subroutine Do_halo_exchange (patch, ims, ime, jms, jme, ips, ipe, jps, jpe, ngho

tag_base = 1000

! Get neighbor ranks in Cartesian topology
call MPI_Cart_shift(cart_comm, 0, 1, nbr_left, nbr_right, ierr)
call MPI_Cart_shift(cart_comm, 1, 1, nbr_down, nbr_up, ierr)
! ---------------------------------------------------------
! ADAPT DIMENSIONS BASED ON MODULE FLAG
! ---------------------------------------------------------
if (topology_dim_order == 0) then
! Default internal behavior [X, Y]
dim_x = 0
dim_y = 1
else
! External framework behavior [Y, X]
dim_x = 1
dim_y = 0
end if

! Get neighbor ranks in Cartesian topology using the mapped dimensions
call MPI_Cart_shift(cart_comm, dim_x, 1, nbr_left, nbr_right, ierr)
call MPI_Cart_shift(cart_comm, dim_y, 1, nbr_down, nbr_up, ierr)
! ---------------------------------------------------------

! Allocate buffers
allocate (sendbuf_right(ny * nghost), recvbuf_left(ny * nghost))
Expand Down Expand Up @@ -282,7 +306,7 @@ subroutine Do_halo_exchange (patch, ims, ime, jms, jme, ips, ipe, jps, jpe, ngho
call MPI_Irecv(recvbuf_up, nx * nghost, MPI_REAL, nbr_up, tag_base + 3, cart_comm, reqs(7), ierr)
call MPI_Isend(sendbuf_down, nx * nghost, MPI_REAL, nbr_down, tag_base + 3, cart_comm, reqs(8), ierr)

! Wait for all communications
! Wait for all communications
call MPI_Waitall(8, reqs, MPI_STATUSES_IGNORE, ierr)

! Unpack ghost zones
Expand Down Expand Up @@ -358,6 +382,8 @@ subroutine Do_halo_exchange_with_corners (patch, ims, ime, jms, jme, ips, ipe, j
real, dimension(:), allocatable :: sendbuf_right, recvbuf_left, sendbuf_left, recvbuf_right
real, dimension(:), allocatable :: sendbuf_up, recvbuf_down, sendbuf_down, recvbuf_up

! New variables to handle the topology mapping
integer :: dim_x, dim_y

#ifdef DM_PARALLEL
call MPI_Comm_rank(cart_comm, rank, ierr)
Expand All @@ -367,9 +393,23 @@ subroutine Do_halo_exchange_with_corners (patch, ims, ime, jms, jme, ips, ipe, j
ny = jpe - jps + 1
tag_base = 1000

! Neighbor ranks
call MPI_Cart_shift (cart_comm, 0, 1, nbr_left, nbr_right, ierr)
call MPI_Cart_shift (cart_comm, 1, 1, nbr_down, nbr_up, ierr)
! ---------------------------------------------------------
! ADAPT DIMENSIONS BASED ON MODULE FLAG
! ---------------------------------------------------------
if (topology_dim_order == 0) then
! Default internal behavior [X, Y]
dim_x = 0
dim_y = 1
else
! External framework behavior [Y, X]
dim_x = 1
dim_y = 0
end if

! Neighbor ranks using mapped dimensions
call MPI_Cart_shift (cart_comm, dim_x, 1, nbr_left, nbr_right, ierr)
call MPI_Cart_shift (cart_comm, dim_y, 1, nbr_down, nbr_up, ierr)
! ---------------------------------------------------------

! Halo exchange in X direction
allocate (sendbuf_right(ny * nghost), recvbuf_left(ny * nghost))
Expand Down Expand Up @@ -586,6 +626,76 @@ subroutine Min_across_mpi_tasks (local_min, cart_comm, global_min)

end subroutine Min_across_mpi_tasks

subroutine Print_cart_info (cart_comm)

#ifdef DM_PARALLEL
use mpi
#endif

implicit none
integer, intent(in) :: cart_comm

integer :: rank, ierr, ndims, topo_type, d
integer, allocatable, dimension(:) :: dims, coords
logical, allocatable, dimension(:) :: periods

#ifdef DM_PARALLEL
! Get the rank of the calling process
call MPI_Comm_rank(cart_comm, rank, ierr)

! 1. Verify this is actually a Cartesian communicator
call MPI_Topo_test(cart_comm, topo_type, ierr)

if (topo_type /= MPI_CART) then
if (rank == 0) print *, "DEBUG ERROR: The provided communicator is NOT a Cartesian topology."
return
end if

! 2. Get the number of dimensions
call MPI_Cartdim_get(cart_comm, ndims, ierr)

if (ierr == MPI_SUCCESS) then
allocate(dims(ndims))
allocate(periods(ndims))
allocate(coords(ndims))

! 3. Extract the full topology information
call MPI_Cart_get(cart_comm, ndims, dims, periods, coords, ierr)

! 4. Print the overall grid configuration (Restricted to Rank 0 to avoid console spam)
if (rank == 0) then
print *, "=========================================="
print *, " CARTESIAN TOPOLOGY DEBUG "
print *, "=========================================="
print *, "Number of Dimensions: ", ndims
do d = 1, ndims
print *, "--- Dimension ", d, " ---"
print *, " Grid Size (Ranks): ", dims(d)
print *, " Is Periodic?: ", periods(d)
end do
print *, "------------------------------------------"
end if

! Wait for Rank 0 to finish printing the header
call MPI_Barrier(cart_comm, ierr)

! 5. Print individual rank coordinates
! (Restricted to Ranks 0 and 1 for your specific debugging needs)
if (rank == 0 .or. rank == 1) then
print *, "DEBUG -> Rank ", rank, " is at Coordinates: ", coords
end if

! Optional: Barrier again to keep standard output clean before the program continues
call MPI_Barrier(cart_comm, ierr)

deallocate(dims, periods, coords)
else
print *, "DEBUG ERROR [Rank ", rank, "]: Failed to get Cartesian dimensions."
end if
#endif

end subroutine Print_cart_info

subroutine Sum_across_mpi_tasks (local_sum, cart_comm, global_sum)

#ifdef DM_PARALLEL
Expand Down
19 changes: 18 additions & 1 deletion state/state_mod.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,7 +16,7 @@ module state_mod
use stderrout_mod, only : Stop_simulation, Print_message
use tiles_mod, only : Calc_tiles_dims
use wrfdata_mod, only : wrfdata_t, G, RERADIUS
use mpi_mod, only : Calc_tasks_in_x_and_y, Calc_patch_dims, Distribute_var2d
use mpi_mod, only : Calc_tasks_in_x_and_y, Calc_patch_dims, Distribute_var2d, Print_cart_info, topology_dim_order

implicit none

Expand Down Expand Up @@ -493,6 +493,19 @@ subroutine Init_domain (this, config_flags, geogrid, &

call this%Init_tiles_in_wrf (config_flags, sr_x, sr_y)

#ifdef DM_PARALLEL
! call Mpi_comm_size (this%cfbm_comm, ntasks, ierr)
! if (ierr /= MPI_SUCCESS) call Stop_simulation ('Problems getting the number of MPI tasks in WRF')
! this%ntasks = ntasks

this%cart_comm = this%cfbm_comm
! Chaning the way halo exchange is done
topology_dim_order = 1

! Debug the topology here
if (DEBUG_LOCAL) call Print_cart_info (this%cart_comm)
#endif

case default

call Stop_simulation ('Not ready to complete fire state initialization 1')
Expand Down Expand Up @@ -851,6 +864,10 @@ subroutine Print_domain (this)
write (OUTPUT_UNIT, *) 'jfms = ', this%jfms, 'jfme = ', this%jfme
write (OUTPUT_UNIT, *) 'kfms = ', this%kfms, 'kfme = ', this%kfme

write (OUTPUT_UNIT, *) 'ifps = ', this%ifps, 'ifpe = ', this%ifpe
write (OUTPUT_UNIT, *) 'jfps = ', this%jfps, 'jfpe = ', this%jfpe
! write (OUTPUT_UNIT, *) 'kfps = ', this%kfps, 'kfpe = ', this%kfpe

! write (OUTPUT_UNIT, *) 'ifts = ', this%ifts, 'ifte = ', this%ifte
! write (OUTPUT_UNIT, *) 'jfts = ', this%jfts, 'jfte = ', this%jfte
write (OUTPUT_UNIT, *) 'kfts = ', this%kfts, 'kfte = ', this%kfte
Expand Down
Loading