From 910f07bed169e5535276a888fac72b6ec2594beb Mon Sep 17 00:00:00 2001 From: Jiaxing Song Date: Sun, 25 Oct 2026 17:49:08 +0800 Subject: [PATCH] Make --mixed build again, and fix its multi-rank parallel I/O Motivation Mixed-precision builds have incompatible storage and working types, and parallel field views use the wrong cell size. Expectation Make the affected interfaces and MPI I/O agree with storage precision while preserving non-mixed behavior. Change A --mixed build (stp = half, wp = single) did not compile with nvfortran, and once it did, runs on two or more ranks with parallel_io wrote corrupted initial-condition and restart files. Build: - m_viscous, m_bubbles_EE, m_acoustic_src and post_process m_start_up passed real(stp) field values to real(wp) dummies. Convert them at the call site, converting each operand before any sum or quotient so the arithmetic does not run in half precision. - m_igr exposes jac through a scalar_field pointer, which is real(stp), while jac was declared real(wp). Every write to jac already converts to stp, so declare it real(stp). - integer_field dropped to integer(kind=1) under --mixed, but s_decode_patch_periodicity, the MPI_INTEGER marker I/O and the GPU_ATOMIC max expect default integers, and encoded periodic IB ids exceed 127. Keep it a default integer. Parallel I/O: a stored cell is 2 bytes under --mixed (mpi_io_p = MPI_BYTE, mpi_io_type = 2), but the field subarrays were built from mpi_p and several file views used mpi_p as their etype, so each rank's block landed at the wrong offset. Build the subarrays from a 2-byte cell type (s_create_mpi_field_subarray), use mpi_io_p as the etype wherever the transfer uses it, and read data_size*mpi_io_type elements in pre_process. test_mixed_mpi_views.py checks the production views from 2 ranks against a serially written file. Non-mixed builds are unchanged: stp == wp, mpi_io_p == mpi_p and mpi_io_type == 1 there, so every change is a no-op. Result The type conversions, integer metadata and file-view fixes are retained. The precheck passes and regression reference files are unchanged. Compiler tests are skipped by the standard precheck; the documented numerical and compiler verification is not rerun by this preparation. Co-authored-by: ruru25254649 Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01WPhkY8p1EHhGY7jScizJmC --- src/common/m_derived_types.fpp | 5 +- src/common/m_mpi_common.fpp | 37 +++-- src/post_process/m_data_input.f90 | 2 +- src/post_process/m_start_up.fpp | 6 +- src/pre_process/m_start_up.fpp | 8 +- src/simulation/m_acoustic_src.fpp | 2 +- src/simulation/m_bubbles_EE.fpp | 6 +- src/simulation/m_data_output.fpp | 8 +- src/simulation/m_igr.fpp | 15 +- src/simulation/m_viscous.fpp | 14 +- toolchain/mfc/test_mixed_mpi_views.py | 228 ++++++++++++++++++++++++++ 11 files changed, 287 insertions(+), 44 deletions(-) create mode 100644 toolchain/mfc/test_mixed_mpi_views.py 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"