diff --git a/driver/initialize_mod.F90 b/driver/initialize_mod.F90 index a3b4fce..9feaa95 100644 --- a/driver/initialize_mod.F90 +++ b/driver/initialize_mod.F90 @@ -149,8 +149,11 @@ 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 @@ -158,10 +161,18 @@ subroutine Init_fire_state_within_wrf (state, 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, & @@ -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 diff --git a/physics/fire_model_mod.F90 b/physics/fire_model_mod.F90 index 0e5679f..ddfe574 100644 --- a/physics/fire_model_mod.F90 +++ b/physics/fire_model_mod.F90 @@ -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) diff --git a/share/mpi_mod.F90 b/share/mpi_mod.F90 index 939cf6a..34291f8 100644 --- a/share/mpi_mod.F90 +++ b/share/mpi_mod.F90 @@ -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 @@ -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) @@ -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)) @@ -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 @@ -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) @@ -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)) @@ -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 diff --git a/state/state_mod.F90 b/state/state_mod.F90 index 51d39c4..1738359 100644 --- a/state/state_mod.F90 +++ b/state/state_mod.F90 @@ -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 @@ -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') @@ -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