diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 1232e3f5ae..5fba76b226 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -30,11 +30,8 @@ module m_derived_types !> Derived type annexing an integer scalar field (SF) type integer_field -#ifdef MFC_MIXED_PRECISION - integer(kind=1), pointer, dimension(:,:,:) :: sf => null() -#else + ! Patch encodings, GPU atomics and MPI_INTEGER I/O require default-width integer metadata. integer, pointer, dimension(:,:,:) :: sf => null() -#endif end type integer_field !> Derived type for levelset diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index c54568d276..5bdbeeb433 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -21,7 +21,7 @@ module m_mpi_common implicit none - private :: s_apply_decomposition_policies + private :: s_apply_decomposition_policies, s_create_mpi_field_subarray integer, private :: v_size $:GPU_DECLARE(create='[v_size]') @@ -175,16 +175,12 @@ contains ! Define the view for each variable do i = 1, alt_sys - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) - call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) + call s_create_mpi_field_subarray(sizes_glb, sizes_loc, start_idx, MPI_IO_DATA%view(i)) end do if (bind_qbmm_fields) then do i = sys_size + 1, sys_size + 2*nb*nnode - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) - call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) + call s_create_mpi_field_subarray(sizes_glb, sizes_loc, start_idx, MPI_IO_DATA%view(i)) end do end if @@ -211,7 +207,7 @@ contains integer, dimension(3) :: sf_start_idx #ifdef MFC_MPI - integer :: i, ierr + integer :: i sf_start_idx = (/0, 0, 0/) @@ -231,14 +227,33 @@ contains ! Define the view for each variable do i = 1, sys_size - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_loc, sizes_loc, sf_start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) - call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) + call s_create_mpi_field_subarray(sizes_loc, sizes_loc, sf_start_idx, MPI_IO_DATA%view(i)) end do #endif end subroutine s_initialize_mpi_data_ds + !> File views advance by stored cells; half-precision cells contain two MPI_BYTE values. + subroutine s_create_mpi_field_subarray(sizes_glb, sizes_loc, starts, view) + + integer, dimension(num_dims), intent(in) :: sizes_glb, sizes_loc, starts + integer, intent(out) :: view + +#ifdef MFC_MPI + integer :: cell_type, ierr + + cell_type = mpi_io_p + if (mpi_io_type /= 1) then + call MPI_TYPE_CONTIGUOUS(mpi_io_type, mpi_io_p, cell_type, ierr) + call MPI_TYPE_COMMIT(cell_type, ierr) + end if + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, starts, MPI_ORDER_FORTRAN, cell_type, view, ierr) + call MPI_TYPE_COMMIT(view, ierr) + if (mpi_io_type /= 1) call MPI_TYPE_FREE(cell_type, ierr) +#endif + + end subroutine s_create_mpi_field_subarray + !> Gather variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index a616aa1b12..393c0bef6c 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -486,7 +486,7 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index c0b6ef8047..cb5f7a1496 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -552,9 +552,9 @@ contains do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end - call s_phase_temperature(q_prim_vf(eqn_idx%cont%beg + l - 1)%sf(i, j, & - & k)/max(q_prim_vf(eqn_idx%E + l)%sf(i, j, k), sgm_eps), & - & q_prim_vf(eqn_idx%E)%sf(i, j, k), l, T) + call s_phase_temperature(real(q_prim_vf(eqn_idx%cont%beg + l - 1)%sf(i, j, k), & + & kind=wp)/max(real(q_prim_vf(eqn_idx%E + l)%sf(i, j, k), kind=wp), & + & sgm_eps), real(q_prim_vf(eqn_idx%E)%sf(i, j, k), kind=wp), l, T) out%q_sf(i, j, k) = T end do end do diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 51aac191a0..e3f529a877 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -469,8 +469,8 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, mpi_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do if (qbmm .and. .not. polytropic) then @@ -480,8 +480,8 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, mpi_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 5ca556ede1..729af3b222 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -239,7 +239,7 @@ contains end do c = c/myRho else - c = f_bulk_modulus(q_prim_vf(eqn_idx%E)%sf(j, k, l), gamma_mix, pi_inf_mix)/myRho + c = f_bulk_modulus(real(q_prim_vf(eqn_idx%E)%sf(j, k, l), kind=wp), gamma_mix, pi_inf_mix)/myRho end if if (model_eqns == model_eqns_5eq .and. bubbles_euler .and. .not. (mpp_lim .and. num_fluids > 1)) then c = c/(1._wp - myalpha(num_fluids)) diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index c1f9547422..266df9eb79 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -265,14 +265,14 @@ contains ! Adaptive time stepping if (adap_dt) then adap_dt_stop = f_advance_step(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, & - & bub_adv_src(j, k, l), divu_in%sf(j, k, l), dmBub_id, dmMass_v, & - & dmMass_n, dmBeta_c, dmBeta_t, dmCson) + & bub_adv_src(j, k, l), real(divu_in%sf(j, k, l), kind=wp), & + & dmBub_id, dmMass_v, dmMass_n, dmBeta_c, dmBeta_t, dmCson) q_cons_vf(rs(q))%sf(j, k, l) = nbub*myR q_cons_vf(vs(q))%sf(j, k, l) = nbub*myV else rddot = f_rddot(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, bub_adv_src(j, & - & k, l), divu_in%sf(j, k, l), dmCson) + & k, l), real(divu_in%sf(j, k, l), kind=wp), dmCson) bub_v_src(j, k, l, q) = nbub*rddot bub_r_src(j, k, l, q) = q_cons_vf(vs(q))%sf(j, k, l) end if diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 112ea52a23..9a2d0b5773 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -991,7 +991,7 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do if (qbmm .and. .not. polytropic) then @@ -1000,7 +1000,7 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if @@ -1010,7 +1010,7 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if @@ -1020,7 +1020,7 @@ contains disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(sys_size + 1), 'native', mpi_info_int, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(sys_size + 1), 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(sys_size + 1)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end if diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 846a039a99..fb63d76c5f 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -23,15 +23,16 @@ module m_igr !> @cond #ifdef __NVCOMPILER_GPU_UNIFIED_MEM - integer, dimension(3) :: nv_uvm_temp_on_gpu - real(wp), pointer, contiguous, dimension(:,:,:) :: jac, jac_rhs, jac_old - real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_host - real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_rhs_host - real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_old_host + integer, dimension(3) :: nv_uvm_temp_on_gpu + real(stp), pointer, contiguous, dimension(:,:,:) :: jac + real(wp), pointer, contiguous, dimension(:,:,:) :: jac_rhs, jac_old + real(stp), allocatable, dimension(:,:,:), pinned, target :: jac_host + real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_rhs_host + real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_old_host #else !> @endcond - real(wp), allocatable, target, dimension(:,:,:) :: jac - real(wp), allocatable, dimension(:,:,:) :: jac_rhs, jac_old + real(stp), allocatable, target, dimension(:,:,:) :: jac + real(wp), allocatable, dimension(:,:,:) :: jac_rhs, jac_old $:GPU_DECLARE(create='[jac, jac_rhs, jac_old]') !> @cond #endif diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 37afd8988e..fe2b954af0 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -70,14 +70,16 @@ contains integer :: i, q if (any_non_newtonian) then - gamma_dot_c = f_compute_shear_rate_from_components(grad_x_vf(1)%sf(j, k, l), grad_y_vf(2)%sf(j, k, l), 0._wp, & - & 0.5_wp*(grad_y_vf(1)%sf(j, k, l) + grad_x_vf(2)%sf(j, k, l)), 0._wp, 0._wp) + gamma_dot_c = f_compute_shear_rate_from_components(real(grad_x_vf(1)%sf(j, k, l), kind=wp), real(grad_y_vf(2)%sf(j, & + & k, l), kind=wp), 0._wp, 0.5_wp*(real(grad_y_vf(1)%sf(j, k, l), kind=wp) + real(grad_x_vf(2)%sf(j, k, l), & + & kind=wp)), 0._wp, 0._wp) #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 if (p > 0) then - gamma_dot_c = f_compute_shear_rate_from_components(grad_x_vf(1)%sf(j, k, l), grad_y_vf(2)%sf(j, k, l), & - & grad_z_vf(3)%sf(j, k, l), 0.5_wp*(grad_y_vf(1)%sf(j, k, l) + grad_x_vf(2)%sf(j, k, l)), & - & 0.5_wp*(grad_z_vf(1)%sf(j, k, l) + grad_x_vf(3)%sf(j, k, l)), 0.5_wp*(grad_z_vf(2)%sf(j, k, & - & l) + grad_y_vf(3)%sf(j, k, l))) + gamma_dot_c = f_compute_shear_rate_from_components(real(grad_x_vf(1)%sf(j, k, l), kind=wp), & + & real(grad_y_vf(2)%sf(j, k, l), kind=wp), real(grad_z_vf(3)%sf(j, k, l), kind=wp), & + & 0.5_wp*(real(grad_y_vf(1)%sf(j, k, l), kind=wp) + real(grad_x_vf(2)%sf(j, k, l), kind=wp)), & + & 0.5_wp*(real(grad_z_vf(1)%sf(j, k, l), kind=wp) + real(grad_x_vf(3)%sf(j, k, l), kind=wp)), & + & 0.5_wp*(real(grad_z_vf(2)%sf(j, k, l), kind=wp) + real(grad_y_vf(3)%sf(j, k, l), kind=wp))) end if #:endif call s_compute_mixture_inv_re(alpha_visc, gamma_dot_c, Res_viscous, Re_visc) diff --git a/toolchain/mfc/test_mixed_mpi_views.py b/toolchain/mfc/test_mixed_mpi_views.py new file mode 100644 index 0000000000..54d7c7d733 --- /dev/null +++ b/toolchain/mfc/test_mixed_mpi_views.py @@ -0,0 +1,228 @@ +"""Exercise production MPI file views and I/O calls without requiring REAL(2).""" + +import os +import re +import shutil +import struct +import subprocess +from pathlib import Path + +import pytest + +ROOT = Path(__file__).resolve().parents[2] + +# The production initializers only associate these buffers, so opaque two-byte +# cells reproduce half storage on compilers that cannot do half arithmetic. +GLOBALS = """ +module test_globals + use mpi + use iso_c_binding, only: c_int8_t, c_int16_t + implicit none + integer, parameter :: mpi_p=MPI_REAL, mpi_io_p=MPI_BYTE, mpi_io_type=2 + type, bind(c) :: cell_t + integer(c_int8_t) :: bits(2) + end type + type scalar_field + type(cell_t), pointer :: sf(:,:,:) => null() + end type + type pres_field + type(cell_t), pointer :: sf(:,:,:,:,:) => null() + end type + type integer_field + integer, pointer :: sf(:,:,:) => null() + end type + type mpi_io_ib_var + integer :: view + type(integer_field) :: var + end type + type mpi_io_var + integer, allocatable :: view(:) + type(scalar_field), allocatable :: var(:) + end type + type(mpi_io_var) :: MPI_IO_DATA + integer :: m,n,p,m_glb,n_glb,p_glb,num_dims,sys_size,nb,nnode,start_idx(3) + logical :: qbmm,polytropic +contains + subroutine s_mpi_abort(message) + character(len=*), intent(in) :: message + integer :: ierr + print *, message + call MPI_ABORT(MPI_COMM_WORLD, 1, ierr) + end subroutine +end module +""" + +DRIVER = """ +program mixed_mpi_views + use test_globals + use production_views + implicit none + integer :: rank, ranks, ierr, ifile, data_size, mpi_info_int, i, x, y, writer, reader + integer :: status(MPI_STATUS_SIZE), errors, total_errors, guard_errors, total_guard_errors, code + integer(kind=MPI_OFFSET_KIND) :: disp + type(scalar_field) :: q(3) + type(cell_t), target :: backing(18,3) + integer(c_int8_t) :: expected(2) + character(len=32) :: filename + + call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + call MPI_COMM_SIZE(MPI_COMM_WORLD, ranks, ierr) + if (ranks /= 2) call s_mpi_abort('This test requires two ranks.') + num_dims=2; sys_size=3; nb=1; nnode=2 + m=2; n=2; p=0; m_glb=2; n_glb=5; p_glb=0 + start_idx=[0,rank*3,0] + qbmm=.false.; polytropic=.true. + data_size=9 + mpi_info_int=MPI_INFO_NULL + allocate(MPI_IO_DATA%var(sys_size),MPI_IO_DATA%view(sys_size)) + do i=1,sys_size + ! Nine guard cells absorb and reveal an erroneous four-byte read. + q(i)%sf(0:m,0:n,0:p) => backing(1:data_size,i) + end do + call s_initialize_mpi_data(q) + errors=0; guard_errors=0 + do writer=0,__WRITERS_COUNT__ + filename='serial.dat' + if (writer > 0) then + write(filename,'(A,I0,A)') 'writer',writer,'.dat' + do i=1,sys_size + do y=0,n + do x=0,m + code=i*1000+(start_idx(2)+y)*3+x+1 + q(i)%sf(x,y,0)%bits=transfer(int(code,c_int16_t),expected) + end do + end do + end do + call MPI_FILE_OPEN(MPI_COMM_WORLD,filename,MPI_MODE_CREATE+MPI_MODE_RDWR,mpi_info_int,ifile,ierr) + call check_mpi() + call MPI_FILE_SET_SIZE(ifile,0_MPI_OFFSET_KIND,ierr) + call check_mpi() + do i=1,sys_size + disp=int(i-1,MPI_OFFSET_KIND)*18*2 + select case(writer) +__WRITERS__ + end select + end do + call MPI_FILE_CLOSE(ifile,ierr) + call check_mpi() + end if + ! Read both the independent serial reference and each parallel writer. + do reader=1,__READERS_COUNT__ + do i=1,sys_size + do x=1,18 + backing(x,i)%bits=-77_c_int8_t + end do + end do + call MPI_FILE_OPEN(MPI_COMM_WORLD,filename,MPI_MODE_RDONLY,mpi_info_int,ifile,ierr) + call check_mpi() + do i=1,sys_size + disp=int(i-1,MPI_OFFSET_KIND)*18*2 + select case(reader) +__READERS__ + end select + do y=0,n + do x=0,m + code=i*1000+(start_idx(2)+y)*3+x+1 + expected=transfer(int(code,c_int16_t),expected) + errors=errors+count(q(i)%sf(x,y,0)%bits /= expected) + end do + end do + do x=data_size+1,18 + errors=errors+count(backing(x,i)%bits /= -77_c_int8_t) + guard_errors=guard_errors+count(backing(x,i)%bits /= -77_c_int8_t) + end do + end do + call MPI_FILE_CLOSE(ifile,ierr) + call check_mpi() + end do + end do + call MPI_ALLREDUCE(errors,total_errors,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,ierr) + call MPI_ALLREDUCE(guard_errors,total_guard_errors,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,ierr) + if (rank == 0) print *, 'mismatched data or guard bytes:',total_errors + if (rank == 0) print *, 'modified guard bytes:',total_guard_errors + do i=1,sys_size + call MPI_TYPE_FREE(MPI_IO_DATA%view(i),ierr) + end do + call MPI_FINALIZE(ierr) + if (total_errors /= 0) stop 1 +contains + subroutine check_mpi(operation) + character(len=*), optional, intent(in) :: operation + character(len=MPI_MAX_ERROR_STRING) :: message + integer :: abort_ierr, length + if (ierr == MPI_SUCCESS) return + call MPI_ERROR_STRING(ierr,message,length,abort_ierr) + print *, 'MPI error on rank',rank,': ',message(:length) + if (present(operation)) print *, 'operation: ',operation + call MPI_ABORT(MPI_COMM_WORLD,ierr,abort_ierr) + end subroutine +end program +""" + + +def production_initializers(): + """Compile the actual initializer bodies, including their helper if present.""" + source = (ROOT / "src/common/m_mpi_common.fpp").read_text() + bodies = [] + for name in ("s_initialize_mpi_data", "s_create_mpi_field_subarray"): + match = re.search(r"^ (?:impure )?subroutine " + name + r"\(.*?^ end subroutine " + name + r"\s*$", source, re.M | re.S) + if match is None: + assert name != "s_initialize_mpi_data", "production MPI initializer not found" + continue + body = match.group() + # These routines' only preprocessor condition is MFC_MPI. Enable it + # without imposing compiler-specific preprocessing flags on the fixture. + body = re.sub(r"^#(?:ifdef MFC_MPI|endif)\s*$", "", body, flags=re.M) + assert not re.search(r"^#", body, re.M), "unexpected initializer preprocessing" + bodies.append(body) + return "module production_views\nuse test_globals\nimplicit none\ncontains\n" + "\n".join(bodies) + "\nend module\n" + + +def production_io_cases(paths, operation): + """Use literal view/transfer calls so wrong production count/type is tested.""" + cases = [] + for path in paths: + source = (ROOT / path).read_text() + pairs = re.findall( + r"(call MPI_FILE_SET_VIEW\(ifile, disp, [^\n]+MPI_IO_DATA%view\(i\)[^\n]+\))\s*\n" + r"\s*(call MPI_FILE_" + operation + r"(?:_ALL)?\(ifile, MPI_IO_DATA%var\(i\)%sf(?:\(:, ?:, ?:\))?,[^\n]+\))", + source, + ) + assert pairs, f"no production {operation} call found in {path}" + for view, transfer in dict.fromkeys(pairs): + cases.append(f"case({len(cases) + 1})\n{view}\ncall check_mpi('SET_VIEW')\n{transfer}\ncall check_mpi('{operation}')") + return "\n".join(cases), len(cases) + + +def test_mixed_parallel_file_views(tmp_path): + if os.environ.get("MFC_SKIP_COMPILER_TESTS", "") == "1": + pytest.skip("MFC_SKIP_COMPILER_TESTS=1 — skipping tests that compile Fortran") + compiler = shutil.which("mpifort") or shutil.which("mpif90") + launcher = shutil.which("mpiexec") or shutil.which("mpirun") + if compiler is None or launcher is None: + pytest.skip("an MPI Fortran compiler and MPI launcher are required") + + writers = ["src/pre_process/m_data_output.fpp", "src/simulation/m_data_output.fpp"] + readers = ["src/pre_process/m_start_up.fpp", "src/simulation/m_start_up.fpp", "src/post_process/m_data_input.f90"] + write_calls, writer_count = production_io_cases(writers, "WRITE") + read_calls, reader_count = production_io_cases(readers, "READ") + driver = DRIVER.replace("__WRITERS__", write_calls).replace("__READERS__", read_calls) + driver = driver.replace("__READERS_COUNT__", str(reader_count)).replace("__WRITERS_COUNT__", str(writer_count)) + sources = [tmp_path / name for name in ("globals.f90", "views.f90", "driver.f90")] + for path, source in zip(sources, (GLOBALS, production_initializers(), driver)): + path.write_text(source) + executable = tmp_path / "mpi_views" + compiled = subprocess.run([compiler, *map(str, sources), "-o", str(executable)], cwd=tmp_path, capture_output=True, text=True, timeout=60, check=False) + assert compiled.returncode == 0, compiled.stdout + compiled.stderr + + # Three fields on a 3x6 grid, split into two 3x3 (odd-sized) blocks. + expected = b"".join(struct.pack("=h", field * 1000 + cell) for field in range(1, 4) for cell in range(1, 19)) + (tmp_path / "serial.dat").write_bytes(expected) + env = os.environ.copy() + # Open MPI otherwise rejects container CI users and two ranks on one slot. + env.update(OMPI_ALLOW_RUN_AS_ROOT="1", OMPI_ALLOW_RUN_AS_ROOT_CONFIRM="1", OMPI_MCA_rmaps_base_oversubscribe="1") + result = subprocess.run([launcher, "-n", "2", str(executable)], cwd=tmp_path, env=env, capture_output=True, text=True, timeout=60, check=False) + assert result.returncode == 0, result.stdout + result.stderr + for writer in range(1, writer_count + 1): + assert (tmp_path / f"writer{writer}.dat").read_bytes() == expected, f"writer {writer} disagrees with the serial reference"