!> @file solver_session.f90 !> @brief Polling-friendly session API built on top of `solver_runtime`. module solver_session use precision, only: wp, safe_vel use config, only: config_t, read_config, validate_config use config_schema, only: config_get_integer, config_get_real, config_get_logical, & config_get_string, config_get_real3, config_set_integer, & config_set_real, config_set_logical, config_set_string, & config_set_real3 use config_dim, only: read_dim use config_2d, only: config_2d_t, read_config_2d, validate_config_2d use path_util, only: resolve_case_path use solver_runtime_2d, only: solver_run_context_2d_t, init_run_context_2d, & run_solver_steps_2d, write_solution_file_2d, & global_point_count_2d, teardown_run_context_2d use config_schema_2d, only: config_2d_get_integer, config_2d_get_real, & config_2d_get_logical, config_2d_get_string, & config_2d_get_real3, config_2d_set_integer, & config_2d_set_real, config_2d_set_logical, & config_2d_set_string, config_2d_set_real3 use, intrinsic :: iso_fortran_env, only: int64 use solution_gather_2d, only: gather_solution_to_root_2d use checkpoint_2d, only: write_checkpoint_2d use option_registry, only: method_fdm use parallel_reductions, only: par_lor use logger, only: log_warn use solver_runtime, only: solver_run_context_t, initialize_runtime, run_solver, & run_solver_steps, finalize_runtime, report_performance_summary, teardown_runtime, & copy_current_solution, write_solution_file, progress_callback_i use solution_gather, only: gather_solution_to_root use mpi_runtime, only: my_rank, parallel_fatal use checkpoint, only: write_checkpoint implicit none private !> Operation completed successfully. integer, parameter, public :: solver_status_ok = 0 !> Caller supplied an invalid handle, key, buffer, or scalar argument. integer, parameter, public :: solver_status_invalid_argument = 1 !> Operation requires an initialised runtime, but the session is not ready. integer, parameter, public :: solver_status_invalid_state = 2 !> Config loading or validation failed. integer, parameter, public :: solver_status_config_error = 3 !> File I/O or other runtime setup/output work failed. integer, parameter, public :: solver_status_io_error = 4 !> Reserved for adapters that need to report temporary v1 exclusivity/busy state. integer, parameter, public :: solver_status_busy = 5 !> Polling-friendly runtime summary exposed to adapters. !! !! All fields are copy-out values. No pointer aliasing or ownership is shared !! with the underlying runtime state. type, public :: solver_progress_t integer :: iteration = 0 !< Completed step count. integer :: n_point = 0 !< Grid-point count (`n_cell + 1`). logical :: is_initialized = .false. !< True after `solver_session_initialize`. logical :: is_finished = .false. !< True once `time_stop` has been reached. real(wp) :: sim_time = 0.0_wp !< Current simulation time. [s] real(wp) :: time_stop = 0.0_wp !< Configured final simulation time. [s] real(wp) :: dt = 0.0_wp !< Most recent or configured time step. [s] real(wp) :: residual = 0.0_wp !< Global residual scalar reported by the runtime. end type solver_progress_t !> Mutable solver session that owns one configuration and, optionally, one runtime. !! !! V1 keeps exactly one runtime context inside a session. Any setter or new !! namelist load invalidates the active runtime so the next initialise call !! rebuilds state from a coherent configuration snapshot. type, public :: solver_session_t type(config_t) :: cfg !< Authoritative editable configuration. type(solver_run_context_t) :: ctx !< Runtime context once initialised. !> Problem dimension: 1 or 2. Set ONLY by solver_session_load_namelist via !! config_dim.read_dim on the namelist PATH; LOAD_CONFIG_INLINE / SET-built !! configs carry no namelist buffer and stay dim=1 (spec 2026-07-03 §2.7). integer :: dim = 1 type(config_2d_t) :: cfg_2d !< Authoritative editable 2D configuration. type(solver_run_context_2d_t) :: ctx_2d !< 2D runtime context once initialised. character(len=512) :: nml_path = '' !< Last LOAD_NAMELIST path (feeds the 2D run log). !> Case directory anchoring relative file paths for a LOAD_CONFIG_INLINE !! config (which has no namelist path to derive it from); '' -> resolve !! against the process cwd (unchanged legacy behaviour). character(len=512) :: case_dir = '' logical :: has_runtime = .false. !< True when `ctx` owns live allocations. character(len=512) :: last_error = '' !< Last surfaced writable-operation error. end type solver_session_t public :: solver_session_create, solver_session_destroy public :: solver_session_load_namelist, solver_session_initialize public :: solver_session_prepare_inline, solver_session_resolve_case_paths public :: solver_session_advance, solver_session_run_to_end public :: solver_session_get_progress, solver_session_get_point_count public :: solver_session_get_global_point_count public :: solver_session_get_global_grid_shape public :: solver_session_copy_global_solution public :: solver_session_copy_global_solution_2d public :: solver_session_copy_solution, solver_session_write_result public :: solver_session_write_checkpoint, solver_session_last_error public :: solver_session_get_integer, solver_session_get_real, solver_session_get_logical public :: solver_session_get_string, solver_session_get_real3 public :: solver_session_set_integer, solver_session_set_real, solver_session_set_logical public :: solver_session_set_string, solver_session_set_real3 public :: progress_callback_i contains !> Reset a session to its default empty state. subroutine solver_session_create(session) type(solver_session_t), intent(out) :: session session = solver_session_t() end subroutine solver_session_create !> Tear down any live runtime allocations and clear the last error. subroutine solver_session_destroy(session) type(solver_session_t), intent(inout) :: session call reset_runtime(session) session % last_error = '' end subroutine solver_session_destroy !> Load configuration from a namelist file into the session. !! !! Any currently initialised runtime is discarded first so the session cannot !! retain stale arrays that disagree with the newly loaded configuration. subroutine solver_session_load_namelist(session, filename, status, message, case_dir) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: filename integer, intent(out), optional :: status character(len=*), intent(out), optional :: message !> Optional case directory (LOAD_NAMELIST's case_dir) to anchor relative !! file paths; when absent/empty the namelist's own directory is used. character(len=*), intent(in), optional :: case_dir logical :: ok character(len=256) :: err integer :: file_dim call reset_runtime(session) ! Dimension pre-pass (spec §2.7): read ONLY &control from the file path. ! On read_dim failure fall through to the 1D reader so missing/corrupt ! files surface the canonical 1D config error unchanged. call read_dim(filename, file_dim, ok, err) if (ok .and. file_dim == 3) then call finish(session, solver_status_config_error, & 'solver_session: dim=3 is not supported (no euler_3d solver)', status, message) return end if if (ok .and. file_dim == 2) then call read_config_2d(filename, session % cfg_2d, ok, err, case_dir=case_dir) if (.not. ok) then call finish(session, solver_status_config_error, err, status, message) return end if session % dim = 2 session % nml_path = filename call finish(session, solver_status_ok, '', status, message) return end if session % dim = 1 session % nml_path = filename call read_config(filename, session % cfg, ok, err, case_dir=case_dir) if (.not. ok) then call finish(session, solver_status_config_error, err, status, message) return end if call finish(session, solver_status_ok, '', status, message) end subroutine solver_session_load_namelist !> Prepare a session to receive a LOAD_CONFIG_INLINE config: discard any live !! runtime, fix the problem dimension, and record the case directory that !! anchors relative file paths (inline configs carry no namelist path to !! derive it from). Must be called BEFORE applying the config entries so the !! dim-aware SET_* setters target the correct 1D/2D config. Collective-safe: !! every rank passes the same decoded dim/case_dir. subroutine solver_session_prepare_inline(session, dim, case_dir) type(solver_session_t), intent(inout) :: session integer, intent(in) :: dim character(len=*), intent(in), optional :: case_dir call reset_runtime(session) session % dim = dim ! An inline config has no source namelist; clear any path left over from a ! prior LOAD_NAMELIST so later logging/attribution does not misreport this ! run as coming from that stale file. session % nml_path = '' if (present(case_dir)) then session % case_dir = case_dir else session % case_dir = '' end if end subroutine solver_session_prepare_inline !> Resolve relative file-valued parameters (grid_file) in the active config !! against the session's case directory. The inline path bypasses !! read_config/read_config_2d, where this resolution otherwise lives, so it is !! applied here after the inline entries land. Absolute paths and an empty !! case_dir are left unchanged. subroutine solver_session_resolve_case_paths(session) type(solver_session_t), intent(inout) :: session if (len_trim(session % case_dir) == 0) return if (session % dim == 2) then session % cfg_2d % grid_file = & resolve_case_path(trim(session % case_dir), trim(session % cfg_2d % grid_file)) else session % cfg % grid_file = & resolve_case_path(trim(session % case_dir), trim(session % cfg % grid_file)) end if end subroutine solver_session_resolve_case_paths !> Validate the current configuration and allocate the runtime context. subroutine solver_session_initialize(session, status, message) type(solver_session_t), intent(inout) :: session integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err call reset_runtime(session) if (session % dim == 2) then block integer :: rstat character(len=512) :: err2 call validate_config_2d(session % cfg_2d, ok, err) if (.not. ok) then call finish(session, solver_status_config_error, err, status, message) return end if session % ctx_2d % nml_file = session % nml_path call init_run_context_2d(session % ctx_2d, session % cfg_2d, rstat, err2) if (rstat /= 0) then session % ctx_2d = solver_run_context_2d_t() call finish(session, solver_status_io_error, trim(err2), status, message) return end if end block session % has_runtime = .true. call finish(session, solver_status_ok, '', status, message) return end if call validate_config(session % cfg, ok, err) if (.not. ok) then call finish(session, solver_status_config_error, err, status, message) return end if call initialize_runtime(session % ctx, session % cfg, 'session', ok, err) if (.not. ok) then call teardown_runtime(session % ctx) call finish(session, solver_status_io_error, err, status, message) return end if session % has_runtime = .true. call finish(session, solver_status_ok, '', status, message) end subroutine solver_session_initialize !> Advance the runtime by at most `max_steps` iterations. !! !! This is the canonical polling-first stepping API used by GUI-facing !! adapters. Checkpoints and compatibility snapshot-file writes still occur !! inside the bounded loop so polling and CLI code paths stay numerically aligned. subroutine solver_session_advance(session, max_steps, steps_taken, finished, status, message) type(solver_session_t), intent(inout) :: session integer, intent(in) :: max_steps integer, intent(out) :: steps_taken logical, intent(out) :: finished integer, intent(out), optional :: status character(len=*), intent(out), optional :: message steps_taken = 0 finished = .false. if (.not. session % has_runtime) then call finish(session, solver_status_invalid_state, 'solver_session: session is not initialised', status, message) return end if if (max_steps < 0) then call finish(session, solver_status_invalid_argument, 'solver_session: max_steps must be >= 0', status, message) return end if if (session % dim == 2) then block integer :: rstat character(len=512) :: rmsg call run_solver_steps_2d(session % ctx_2d, max_steps, steps_taken, finished, rstat, rmsg) if (rstat /= 0) then call finish(session, solver_status_invalid_state, trim(rmsg), status, message) return end if end block call finish(session, solver_status_ok, '', status, message) return end if call run_solver_steps(session % ctx, max_steps, steps_taken, finished) call finish(session, solver_status_ok, '', status, message) end subroutine solver_session_advance !> Run the current session until `time_stop` is reached. !! !! When an `on_progress` callback is supplied, the runtime fires it every !! `every_steps` iterations or every `every_seconds` wall-clock seconds !! (whichever comes first) from inside the bounded step loop. With no !! callback bound, behaviour is byte-identical to a callback-free run. subroutine solver_session_run_to_end(session, status, message, & on_progress, every_steps, every_seconds) type(solver_session_t), intent(inout) :: session integer, intent(out), optional :: status character(len=*), intent(out), optional :: message procedure(progress_callback_i), optional :: on_progress integer, intent(in), optional :: every_steps real(wp), intent(in), optional :: every_seconds if (.not. session % has_runtime) then call finish(session, solver_status_invalid_state, 'solver_session: session is not initialised', status, message) return end if if (session % dim == 2) then block integer :: steps_taken2, rstat logical :: finished2 character(len=512) :: rmsg ! 2D live updates ride the ADVANCE + COPY_SOLUTION polling loop ! (spec §2.3); the 1D-only progress-tick callback is intentionally ! not wired for dim=2 (on_progress/every_* are ignored here). call run_solver_steps_2d(session % ctx_2d, huge(1), steps_taken2, finished2, rstat, rmsg) if (rstat /= 0) then call finish(session, solver_status_invalid_state, trim(rmsg), status, message) return end if end block call finish(session, solver_status_ok, '', status, message) return end if call run_solver(session % ctx, on_progress=on_progress, & every_steps=every_steps, & every_seconds=every_seconds) call finish(session, solver_status_ok, '', status, message) end subroutine solver_session_run_to_end !> Copy out a lightweight progress snapshot for polling clients. subroutine solver_session_get_progress(session, progress, status, message) type(solver_session_t), intent(in) :: session type(solver_progress_t), intent(out) :: progress integer, intent(out), optional :: status character(len=*), intent(out), optional :: message progress = solver_progress_t() progress % is_initialized = session % has_runtime if (session % dim == 2) then if (session % has_runtime) then progress % iteration = session % ctx_2d % iter progress % n_point = session % ctx_2d % state % nx_local * session % ctx_2d % state % ny_local progress % sim_time = session % ctx_2d % t progress % time_stop = session % ctx_2d % state % cfg % time_stop progress % dt = session % ctx_2d % state % dt progress % residual = session % ctx_2d % resid_glob progress % is_finished = session % ctx_2d % run_complete else progress % time_stop = session % cfg_2d % time_stop progress % dt = session % cfg_2d % dt progress % n_point = session % cfg_2d % nx * session % cfg_2d % ny ! pre-init FVM-cell estimate end if call finish_readonly(solver_status_ok, '', status, message) return end if ! Even before initialisation, adapters can discover the expected grid size ! and configured time window to size buffers and present form defaults. if (session % has_runtime) then progress % iteration = session % ctx % iter progress % n_point = session % ctx % state % n_pt progress % sim_time = session % ctx % t progress % time_stop = session % ctx % state % cfg % time_stop progress % dt = session % ctx % state % dt progress % residual = session % ctx % state % resid_glob progress % is_finished = session % ctx % run_complete else progress % time_stop = session % cfg % time_stop progress % dt = session % cfg % dt progress % n_point = session % cfg % n_cell + 1 end if call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_get_progress !> Return the current grid-point count expected by solution copy-out buffers. subroutine solver_session_get_point_count(session, n_point, status, message) type(solver_session_t), intent(in) :: session integer, intent(out) :: n_point integer, intent(out), optional :: status character(len=*), intent(out), optional :: message if (session % dim == 2) then if (session % has_runtime) then n_point = session % ctx_2d % state % nx_local * session % ctx_2d % state % ny_local else n_point = session % cfg_2d % nx * session % cfg_2d % ny end if call finish_readonly(solver_status_ok, '', status, message) return end if if (session % has_runtime) then n_point = session % ctx % state % n_pt else n_point = session % cfg % n_cell + 1 end if call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_get_point_count !> Return the *global* grid-point count (= n_cell + 1, identical on every !! rank). Distinct from solver_session_get_point_count, which returns !! this rank's local interior point count after domain decomposition. !! Callers that need to size a whole-domain buffer (e.g. the GUI's !! plot frame, post-run result reader) want this value. subroutine solver_session_get_global_point_count(session, n_point_global, status, message) type(solver_session_t), intent(in) :: session integer, intent(out) :: n_point_global integer, intent(out), optional :: status character(len=*), intent(out), optional :: message if (session % dim == 2) then if (session % has_runtime) then n_point_global = global_point_count_2d(session % ctx_2d) else n_point_global = session % cfg_2d % nx * session % cfg_2d % ny end if call finish_readonly(solver_status_ok, '', status, message) return end if if (session % has_runtime) then n_point_global = session % ctx % state % n_pt_global else n_point_global = session % cfg % n_cell + 1 end if call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_get_global_point_count !> Global structured-grid shape. dim=2: (nx_global, ny_global); dim=1: !! (n_pt_global, 1). Feeds the nx/ny fields of the 2D INITIALIZE and !! COPY_SOLUTION replies (spec §4.2). subroutine solver_session_get_global_grid_shape(session, nx, ny, status, message) type(solver_session_t), intent(in) :: session integer, intent(out) :: nx, ny integer, intent(out), optional :: status character(len=*), intent(out), optional :: message if (session % dim == 2) then if (session % has_runtime) then nx = session % ctx_2d % state % decomp_2d % nx_global ny = session % ctx_2d % state % decomp_2d % ny_global else nx = session % cfg_2d % nx ny = session % cfg_2d % ny end if else if (session % has_runtime) then nx = session % ctx % state % n_pt_global else nx = session % cfg % n_cell + 1 end if ny = 1 end if call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_get_global_grid_shape !> Copy the current primitive-variable solution into caller-owned arrays. !! !! All four arrays must be sized exactly to `solver_session_get_point_count`. !! The session never returns aliased storage across the API boundary. subroutine solver_session_copy_solution(session, x, rho, u, p, status, message) type(solver_session_t), intent(in) :: session real(wp), intent(out) :: x(:), rho(:), u(:), p(:) integer, intent(out), optional :: status character(len=*), intent(out), optional :: message integer :: n_point if (.not. session % has_runtime) then call finish_readonly(solver_status_invalid_state, 'solver_session: session is not initialised', status, message) return end if if (session % dim == 2) then call finish_readonly(solver_status_invalid_state, & 'solver_session: copy_solution is 1D-only; use '// & 'solver_session_copy_global_solution_2d', status, message) return end if n_point = session % ctx % state % n_pt if (size(x) /= n_point .or. size(rho) /= n_point .or. size(u) /= n_point .or. size(p) /= n_point) then call finish_readonly(solver_status_invalid_argument, & 'solver_session: solution buffers must match the solver grid size', status, message) return end if call copy_current_solution(session % ctx, x, rho, u, p) call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_copy_solution !> Gather the current solution from every rank onto rank 0 and fill the !! caller-owned global arrays. Collective: must be invoked on every rank !! with the same call sequence as the MPI worker pool. On non-root ranks !! the output arrays may be size 0 and are not written. !! !! Output buffer sizing (on rank 0): !! x_global, rho_global, u_global, p_global must all be of length !! solver_session_get_global_point_count. subroutine solver_session_copy_global_solution(session, x_global, rho_global, & u_global, p_global, status, message) type(solver_session_t), intent(inout) :: session ! gather_buf is written real(wp), intent(out) :: x_global(:), rho_global(:), u_global(:), p_global(:) integer, intent(out), optional :: status character(len=*), intent(out), optional :: message real(wp), allocatable :: x_local(:), rho_local(:), u_local(:), p_local(:) real(wp), allocatable :: local_prim(:, :) integer :: n_local, n_global, ipt, ierr, expected logical :: sizes_ok if (.not. session % has_runtime) then call finish_readonly(solver_status_invalid_state, & 'solver_session: session is not initialised', status, message) return end if n_local = session % ctx % state % n_pt n_global = session % ctx % state % n_pt_global ! Per-rank local primitives. copy_current_solution already turns the ! conserved state into (rho, u, p) and a local x array, but we only need ! the primitives for the gather; x is reconstructed globally on rank 0 ! from cfg geometry. allocate (x_local(n_local), rho_local(n_local), u_local(n_local), p_local(n_local), stat=ierr) if (ierr /= 0) call parallel_fatal('solver_session: local primitive arrays allocation failed') call copy_current_solution(session % ctx, x_local, rho_local, u_local, p_local) allocate (local_prim(3, n_local), stat=ierr) if (ierr /= 0) call parallel_fatal('solver_session: local_prim allocation failed') local_prim(1, :) = rho_local local_prim(2, :) = u_local local_prim(3, :) = p_local deallocate (x_local, rho_local, u_local, p_local, stat=ierr) ! Rank-local expected buffer size: the full domain on rank 0, zero off-root ! (Cortex — and the COPY_SOLUTION contract — pass whole-domain buffers only ! on rank 0 and zero-length buffers on every other rank). Agree the size ! check across ranks with par_lor so every rank takes the SAME branch: a ! purely local check made non-root ranks (size 0) return early while rank 0 ! (size n_global) marched into the collective gather below, diverging the ! communicator and triggering MPI_Abort on the first live frame at np>1. ! Mirrors solver_session_copy_global_solution_2d. if (my_rank() == 0) then expected = n_global else expected = 0 end if sizes_ok = size(x_global) == expected .and. size(rho_global) == expected & .and. size(u_global) == expected .and. size(p_global) == expected if (par_lor(.not. sizes_ok)) then deallocate (local_prim, stat=ierr) call finish_readonly(solver_status_invalid_argument, & 'solver_session: global solution buffers must be of size n_global '// & 'on rank 0 (zero-length off-root)', & status, message) return end if call gather_solution_to_root(local_prim, n_local, session % ctx % state % decomp, & session % ctx % state % gather_buf) deallocate (local_prim, stat=ierr) if (my_rank() == 0) then do ipt = 1, n_global x_global(ipt) = session % ctx % state % mesh % x_global(ipt) end do rho_global(:) = session % ctx % state % gather_buf(1, 1:n_global) u_global(:) = session % ctx % state % gather_buf(2, 1:n_global) p_global(:) = session % ctx % state % gather_buf(3, 1:n_global) end if call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_copy_global_solution !> Gather the 2D solution to rank 0 and pack the requested primitive fields !! into ONE flat buffer, one nx*ny block per primitive in request order, !! each block i-fastest (x-contiguous) — the pack order of !! solution_gather_2d.write_global_field, so these fields match !! result_2d.dat columns exactly. `offsets` are 0-based BYTE offsets !! ((k-1)*nx*ny*8), computed identically on every rank. Supported names: !! x, y, rho, u, v, p; unknown names copy x with a warning (1D wire-compat !! leniency). Collective: every rank must call; buffer-size agreement is !! reduced with par_lor so no rank can return early past the gather. subroutine solver_session_copy_global_solution_2d(session, primitives, buf, offsets, & nx, ny, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: primitives(:) real(wp), intent(out) :: buf(:) integer(int64), intent(out) :: offsets(:) integer, intent(out) :: nx, ny integer, intent(out), optional :: status character(len=*), intent(out), optional :: message real(wp), allocatable :: gf(:, :, :), gxc(:, :), gyc(:, :) logical :: gok, sizes_ok, curvi, is_fdm character(len=256) :: gmsg integer :: n_prims, k, i, j integer(int64) :: base, expected real(wp) :: rho, uu, vv, gam, xx, yy nx = 0 ny = 0 buf = 0.0_wp offsets = 0_int64 if (session % dim /= 2) then call finish_readonly(solver_status_invalid_state, & 'solver_session: copy_global_solution_2d requires a dim=2 session', & status, message) return end if if (.not. session % has_runtime) then call finish_readonly(solver_status_invalid_state, & 'solver_session: session is not initialised', status, message) return end if nx = session % ctx_2d % state % decomp_2d % nx_global ny = session % ctx_2d % state % decomp_2d % ny_global n_prims = size(primitives) do k = 1, min(n_prims, size(offsets)) offsets(k) = int(k - 1, int64) * int(nx, int64) * int(ny, int64) * 8_int64 end do ! Rank-local expected size: full pack on rank 0, empty off-root. Agree ! across ranks BEFORE the gather so every rank takes the same branch. if (my_rank() == 0) then expected = int(n_prims, int64) * int(nx, int64) * int(ny, int64) else expected = 0_int64 end if sizes_ok = size(buf, kind=int64) == expected .and. size(offsets) == n_prims if (par_lor(.not. sizes_ok)) then call finish_readonly(solver_status_invalid_argument, & 'solver_session: 2D copy buffer must be n_prims*nx*ny on rank 0 '// & '(0 off-root) with one offset per primitive', status, message) return end if curvi = .not. session % ctx_2d % state % mesh % uniform if (curvi) then call gather_solution_to_root_2d(session % ctx_2d % state, gf, gok, gmsg, gxc, gyc) else call gather_solution_to_root_2d(session % ctx_2d % state, gf, gok, gmsg) end if if (par_lor(.not. gok)) then call finish_readonly(solver_status_io_error, & 'solver_session: 2D solution gather failed', status, message) return end if if (my_rank() == 0) then gam = session % ctx_2d % state % cfg % gam is_fdm = trim(session % ctx_2d % state % blocks(1) % method) == method_fdm do k = 1, n_prims base = int(k - 1, int64) * int(nx, int64) * int(ny, int64) do j = 1, ny do i = 1, nx ! Coordinates mirror write_global_field's dispatch exactly. if (curvi) then xx = gxc(i, j) yy = gyc(i, j) else if (is_fdm) then xx = session % ctx_2d % state % cfg % x_left + real(i - 1, wp) * session % ctx_2d % state % dx yy = session % ctx_2d % state % cfg % y_left + real(j - 1, wp) * session % ctx_2d % state % dy else xx = session % ctx_2d % state % cfg % x_left + (real(i, wp) - 0.5_wp) * session % ctx_2d % state % dx yy = session % ctx_2d % state % cfg % y_left + (real(j, wp) - 0.5_wp) * session % ctx_2d % state % dy end if rho = gf(1, i, j) uu = safe_vel(gf(2, i, j), rho) vv = safe_vel(gf(3, i, j), rho) select case (trim(primitives(k))) case ('x') buf(base + int(j - 1, int64) * nx + i) = xx case ('y') buf(base + int(j - 1, int64) * nx + i) = yy case ('rho') buf(base + int(j - 1, int64) * nx + i) = rho case ('u') buf(base + int(j - 1, int64) * nx + i) = uu case ('v') buf(base + int(j - 1, int64) * nx + i) = vv case ('p') buf(base + int(j - 1, int64) * nx + i) = & (gam - 1.0_wp) * (gf(4, i, j) - 0.5_wp * rho * (uu * uu + vv * vv)) case default ! Wire-compat leniency (mirrors the 1D handler): copy x for an ! unknown primitive name; the warning fires once per block below. buf(base + int(j - 1, int64) * nx + i) = xx end select end do end do if (trim(primitives(k)) /= 'x' .and. trim(primitives(k)) /= 'y' .and. & trim(primitives(k)) /= 'rho' .and. trim(primitives(k)) /= 'u' .and. & trim(primitives(k)) /= 'v' .and. trim(primitives(k)) /= 'p') then call log_warn('COPY_SOLUTION(2D): unknown primitive "'// & trim(primitives(k))//'", copying x') end if end do end if if (allocated(gf)) deallocate (gf) if (allocated(gxc)) deallocate (gxc) if (allocated(gyc)) deallocate (gyc) call finish_readonly(solver_status_ok, '', status, message) end subroutine solver_session_copy_global_solution_2d !> Write the current solution in the standard `result.dat`-style text format. !! !! Completed runs also flush the opt-in performance summary here so the !! session-based CLI, Python bindings, and C ABI preserve the same timing !! behaviour as the legacy direct runtime driver. subroutine solver_session_write_result(session, filename, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in), optional :: filename integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err character(len=256) :: output_path if (.not. session % has_runtime) then call finish(session, solver_status_invalid_state, 'solver_session: session is not initialised', status, message) return end if if (session % dim == 2) then output_path = trim(session % ctx_2d % state % cfg % output_file) if (present(filename)) then if (len_trim(filename) > 0) output_path = trim(filename) end if call write_solution_file_2d(session % ctx_2d, trim(output_path), ok, err) if (.not. ok) then call finish(session, solver_status_io_error, err, status, message) return end if ! No performance summary: the 2D runtime has no do_timing knob. call finish(session, solver_status_ok, '', status, message) return end if output_path = trim(session % ctx % state % cfg % output_file) if (present(filename)) then if (len_trim(filename) > 0) output_path = trim(filename) end if call write_solution_file(session % ctx, trim(output_path), ok, err) if (.not. ok) then call finish(session, solver_status_io_error, err, status, message) return end if call report_performance_summary(session % ctx) call finish(session, solver_status_ok, '', status, message) end subroutine solver_session_write_result !> Force an immediate checkpoint write using the configured or overridden base name. !! !! @param[out] written_path Optional. On success, the real on-disk path the !! writer produced (e.g. `<base>_<iter>.bin`) — NOT simply `base`, since the !! writer appends the iteration and extension. Cortex's WRITE_CHECKPOINT !! reply surfaces this in its `files` field (protocol.md); left unset (blank) !! on failure. subroutine solver_session_write_checkpoint(session, base, status, message, written_path) type(solver_session_t), intent(inout) :: session character(len=*), intent(in), optional :: base integer, intent(out), optional :: status character(len=*), intent(out), optional :: message character(len=*), intent(out), optional :: written_path logical :: ok character(len=256) :: err character(len=256) :: checkpoint_base character(len=512) :: file_written if (present(written_path)) written_path = '' if (.not. session % has_runtime) then call finish(session, solver_status_invalid_state, 'solver_session: session is not initialised', status, message) return end if if (session % dim == 2) then checkpoint_base = trim(session % ctx_2d % state % cfg % checkpoint_file) if (present(base)) then if (len_trim(base) > 0) checkpoint_base = trim(base) end if call write_checkpoint_2d(session % ctx_2d % state, trim(checkpoint_base), & session % ctx_2d % t, session % ctx_2d % iter, ok, err, file_written, & t_comp=session % ctx_2d % t_comp) if (.not. ok) then call finish(session, solver_status_io_error, err, status, message) return end if if (present(written_path)) written_path = trim(file_written) call finish(session, solver_status_ok, '', status, message) return end if checkpoint_base = trim(session % ctx % state % cfg % checkpoint_file) if (present(base)) then if (len_trim(base) > 0) checkpoint_base = trim(base) end if call write_checkpoint(session % ctx % state, trim(checkpoint_base), session % ctx % t, session % ctx % iter, & ok, err, file_written, t_comp=session % ctx % t_comp) if (.not. ok) then call finish(session, solver_status_io_error, err, status, message) return end if if (present(written_path)) written_path = trim(file_written) call finish(session, solver_status_ok, '', status, message) end subroutine solver_session_write_checkpoint !> Copy the last stored writable-operation error message. subroutine solver_session_last_error(session, message) type(solver_session_t), intent(in) :: session character(len=*), intent(out) :: message message = trim(session % last_error) end subroutine solver_session_last_error !> Read an integer configuration field by canonical schema key. subroutine solver_session_get_integer(session, key, value, status, message) type(solver_session_t), intent(in) :: session character(len=*), intent(in) :: key integer, intent(out) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err if (session % dim == 2) then call config_2d_get_integer(session % cfg_2d, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if call config_get_integer(session % cfg, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_get_integer !> Read a scalar real configuration field by canonical schema key. subroutine solver_session_get_real(session, key, value, status, message) type(solver_session_t), intent(in) :: session character(len=*), intent(in) :: key real(wp), intent(out) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err if (session % dim == 2) then call config_2d_get_real(session % cfg_2d, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if call config_get_real(session % cfg, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_get_real !> Read a logical configuration field by canonical schema key. subroutine solver_session_get_logical(session, key, value, status, message) type(solver_session_t), intent(in) :: session character(len=*), intent(in) :: key logical, intent(out) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err if (session % dim == 2) then call config_2d_get_logical(session % cfg_2d, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if call config_get_logical(session % cfg, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_get_logical !> Read a string or choice-token configuration field by canonical schema key. subroutine solver_session_get_string(session, key, value, status, message) type(solver_session_t), intent(in) :: session character(len=*), intent(in) :: key character(len=*), intent(out) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err if (session % dim == 2) then call config_2d_get_string(session % cfg_2d, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if call config_get_string(session % cfg, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_get_string !> Read a real-3 configuration field by canonical schema key. subroutine solver_session_get_real3(session, key, value, status, message) type(solver_session_t), intent(in) :: session character(len=*), intent(in) :: key real(wp), intent(out) :: value(3) integer, intent(out), optional :: status character(len=*), intent(out), optional :: message logical :: ok character(len=256) :: err if (session % dim == 2) then call config_2d_get_real3(session % cfg_2d, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if call config_get_real3(session % cfg, key, value, ok, err) call finish_readonly(merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_get_real3 !> Set an integer configuration field and invalidate any live runtime. subroutine solver_session_set_integer(session, key, value, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: key integer, intent(in) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message type(config_t) :: next_cfg logical :: ok character(len=256) :: err if (session % dim == 2) then block type(config_2d_t) :: next_cfg2 next_cfg2 = session % cfg_2d call config_2d_set_integer(next_cfg2, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg_2d = next_cfg2 end if end block call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if next_cfg = session % cfg call config_set_integer(next_cfg, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg = next_cfg end if call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_set_integer !> Set a scalar real configuration field and invalidate any live runtime. subroutine solver_session_set_real(session, key, value, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: key real(wp), intent(in) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message type(config_t) :: next_cfg logical :: ok character(len=256) :: err if (session % dim == 2) then block type(config_2d_t) :: next_cfg2 next_cfg2 = session % cfg_2d call config_2d_set_real(next_cfg2, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg_2d = next_cfg2 end if end block call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if next_cfg = session % cfg call config_set_real(next_cfg, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg = next_cfg end if call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_set_real !> Set a logical configuration field and invalidate any live runtime. subroutine solver_session_set_logical(session, key, value, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: key logical, intent(in) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message type(config_t) :: next_cfg logical :: ok character(len=256) :: err if (session % dim == 2) then block type(config_2d_t) :: next_cfg2 next_cfg2 = session % cfg_2d call config_2d_set_logical(next_cfg2, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg_2d = next_cfg2 end if end block call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if next_cfg = session % cfg call config_set_logical(next_cfg, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg = next_cfg end if call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_set_logical !> Set a string or choice-token configuration field and invalidate any runtime. subroutine solver_session_set_string(session, key, value, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: key character(len=*), intent(in) :: value integer, intent(out), optional :: status character(len=*), intent(out), optional :: message type(config_t) :: next_cfg logical :: ok character(len=256) :: err if (session % dim == 2) then block type(config_2d_t) :: next_cfg2 next_cfg2 = session % cfg_2d call config_2d_set_string(next_cfg2, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg_2d = next_cfg2 end if end block call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if next_cfg = session % cfg call config_set_string(next_cfg, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg = next_cfg end if call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_set_string !> Set a real-3 configuration field and invalidate any live runtime. subroutine solver_session_set_real3(session, key, value, status, message) type(solver_session_t), intent(inout) :: session character(len=*), intent(in) :: key real(wp), intent(in) :: value(3) integer, intent(out), optional :: status character(len=*), intent(out), optional :: message type(config_t) :: next_cfg logical :: ok character(len=256) :: err if (session % dim == 2) then block type(config_2d_t) :: next_cfg2 next_cfg2 = session % cfg_2d call config_2d_set_real3(next_cfg2, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg_2d = next_cfg2 end if end block call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), & trim(err), status, message) return end if next_cfg = session % cfg call config_set_real3(next_cfg, key, value, ok, err) if (ok) then call reset_runtime(session) session % cfg = next_cfg end if call finish(session, merge(solver_status_ok, solver_status_invalid_argument, ok), trim(err), status, message) end subroutine solver_session_set_real3 !> Tear down the live runtime context while keeping editable config state. !! !! This is called before every mutating config change so the next initialise !! pass cannot accidentally reuse arrays, timers, or procedure pointers from !! an incompatible earlier run. subroutine reset_runtime(session) type(solver_session_t), intent(inout) :: session if (session % has_runtime) then if (session % dim == 2) then call teardown_run_context_2d(session % ctx_2d) session % ctx_2d = solver_run_context_2d_t() else call teardown_runtime(session % ctx) session % ctx = solver_run_context_t() end if session % has_runtime = .false. end if end subroutine reset_runtime !> Store the last writable-operation error and mirror it to optional outputs. subroutine finish(session, status_code, err, status, message) type(solver_session_t), intent(inout) :: session integer, intent(in) :: status_code character(len=*), intent(in) :: err integer, intent(out), optional :: status character(len=*), intent(out), optional :: message session % last_error = trim(err) if (present(status)) status = status_code if (present(message)) message = trim(err) end subroutine finish !> Mirror readonly-operation status without mutating the session state. subroutine finish_readonly(status_code, err, status, message) integer, intent(in) :: status_code character(len=*), intent(in) :: err integer, intent(out), optional :: status character(len=*), intent(out), optional :: message if (present(status)) status = status_code if (present(message)) message = trim(err) end subroutine finish_readonly end module solver_session