register_common Subroutine

private subroutine register_common(this, file, var, is_3d, i0, j0, nx, ny, nz, dest_i0, dest_j0, dest_n1, dest_n2, dest_n3, time_mode, cycle_period, t_offset, t_scale, scale, add_offset, oor, id, edge, ierr)

Shared registration body for register_2d/_3d/_segment_2d/_segment_3d. (i0, j0, nx, ny, nz) are FILE-side start/count (already resolved by the caller — plain global-offset slicing for the base variants, degenerate-axis geometry for the segment variants).

Arguments

Type IntentOptional Attributes Name
class(ocean_data_input_t), intent(inout) :: this
character(len=*), intent(in) :: file
character(len=*), intent(in) :: var
logical, intent(in) :: is_3d
integer, intent(in) :: i0
integer, intent(in) :: j0
integer, intent(in) :: nx
integer, intent(in) :: ny
integer, intent(in) :: nz
integer, intent(in) :: dest_i0
integer, intent(in) :: dest_j0
integer, intent(in) :: dest_n1
integer, intent(in) :: dest_n2
integer, intent(in) :: dest_n3
character(len=*), intent(in), optional :: time_mode
real(kind=wp), intent(in), optional :: cycle_period
real(kind=wp), intent(in), optional :: t_offset
real(kind=wp), intent(in), optional :: t_scale
real(kind=wp), intent(in), optional :: scale
real(kind=wp), intent(in), optional :: add_offset
integer, intent(in), optional :: oor
integer, intent(out) :: id
integer, intent(in), optional :: edge
integer, intent(out), optional :: ierr

Non-zero (OCEAN_STATUS_ERR_SETUP/OCEAN_STATUS_ERR_IO) on a registry/file/dimension failure when present; absent behaves as today (error stop).

Calls

proc~~register_common~~CallsGraph proc~register_common register_common error error proc~register_common->error nf90_inq_varid nf90_inq_varid proc~register_common->nf90_inq_varid nf90_inquire_dimension nf90_inquire_dimension proc~register_common->nf90_inquire_dimension nf90_inquire_variable nf90_inquire_variable proc~register_common->nf90_inquire_variable proc~data_input_read_slab_impl data_input_read_slab_impl proc~register_common->proc~data_input_read_slab_impl proc~data_input_time_mode_from_string data_input_time_mode_from_string proc~register_common->proc~data_input_time_mode_from_string proc~data_input_time_scale_from_units data_input_time_scale_from_units proc~register_common->proc~data_input_time_scale_from_units proc~dims_geometry_ok dims_geometry_ok proc~register_common->proc~dims_geometry_ok proc~fail fail proc~register_common->proc~fail proc~nc_check nc_check proc~register_common->proc~nc_check proc~nc_close nc_close proc~register_common->proc~nc_close proc~nc_get_att_text nc_get_att_text proc~register_common->proc~nc_get_att_text proc~nc_get_var_1d nc_get_var_1d proc~register_common->proc~nc_get_var_1d proc~nc_open_read nc_open_read proc~register_common->proc~nc_open_read proc~reg_io_ok reg_io_ok proc~register_common->proc~reg_io_ok proc~resolve_time_var resolve_time_var proc~register_common->proc~resolve_time_var to_string to_string proc~register_common->to_string proc~data_input_workspace_ensure data_input_workspace_ensure proc~data_input_read_slab_impl->proc~data_input_workspace_ensure proc~nc_get_var_slab_3d nc_get_var_slab_3d proc~data_input_read_slab_impl->proc~nc_get_var_slab_3d proc~data_input_time_mode_from_string->error to_lower to_lower proc~data_input_time_mode_from_string->to_lower proc~data_input_time_scale_from_units->to_lower proc~fail->error proc~error_ring_push error_ring_push proc~fail->proc~error_ring_push proc~nc_check->proc~fail nf90_strerror nf90_strerror proc~nc_check->nf90_strerror proc~nc_close->proc~nc_check nf90_close nf90_close proc~nc_close->nf90_close nf90_get_att nf90_get_att proc~nc_get_att_text->nf90_get_att proc~nc_get_var_1d->proc~nc_check nf90_get_var nf90_get_var proc~nc_get_var_1d->nf90_get_var proc~nc_open_read->proc~nc_check nf90_open nf90_open proc~nc_open_read->nf90_open proc~reg_io_ok->proc~nc_close proc~resolve_time_var->nf90_inq_varid proc~resolve_time_var->nf90_inquire_dimension proc~nc_get_var_slab_3d->proc~nc_check proc~nc_get_var_slab_3d->nf90_get_var

Called by

proc~~register_common~~CalledByGraph proc~register_common register_common proc~ocean_data_input_register_2d ocean_data_input_register_2d proc~ocean_data_input_register_2d->proc~register_common proc~ocean_data_input_register_3d ocean_data_input_register_3d proc~ocean_data_input_register_3d->proc~register_common proc~ocean_data_input_register_segment_2d ocean_data_input_register_segment_2d proc~ocean_data_input_register_segment_2d->proc~register_common proc~ocean_data_input_register_segment_3d ocean_data_input_register_segment_3d proc~ocean_data_input_register_segment_3d->proc~register_common proc~ocean_data_input_load_static_2d ocean_data_input_load_static_2d proc~ocean_data_input_load_static_2d->proc~ocean_data_input_register_2d proc~register_tag register_tag proc~register_tag->proc~ocean_data_input_register_2d proc~ocean_data_forcing_configure ocean_data_forcing_configure proc~ocean_data_forcing_configure->proc~register_tag proc~seed_cavity_draft seed_cavity_draft proc~seed_cavity_draft->proc~ocean_data_input_load_static_2d proc~engine_setup engine_setup proc~engine_setup->proc~ocean_data_forcing_configure proc~ocean_state_seed_from_cfg ocean_state_seed_from_cfg proc~engine_setup->proc~ocean_state_seed_from_cfg proc~ocean_state_seed_from_cfg->proc~seed_cavity_draft proc~complete_ocean_create complete_ocean_create proc~complete_ocean_create->proc~engine_setup proc~driver_run_ocean driver_run_ocean proc~driver_run_ocean->proc~engine_setup proc~driver_validate driver_validate proc~driver_validate->proc~engine_setup

Variables

Type Visibility Attributes Name Initial
integer, private :: d1
integer, private :: d2
integer, private :: dt
integer, private :: dz
integer, private :: expect_nd
integer, private :: k
integer, private :: local_ierr
integer, private :: ncid
integer, private :: nt
integer, private :: status
real(kind=wp), private :: t_scale_eff
integer, private :: tdimid
integer, private :: tvarid
logical, private :: units_ok
character(len=:), private, allocatable :: units_str
integer, private :: var_dimids(4)
integer, private :: var_ndims
integer, private :: varid

Source Code

   subroutine register_common(this, file, var, is_3d, i0, j0, nx, ny, nz, &
                              dest_i0, dest_j0, dest_n1, dest_n2, dest_n3, &
                              time_mode, cycle_period, t_offset, t_scale, scale, add_offset, &
                              oor, id, edge, ierr)
      !! Shared registration body for register_2d/_3d/_segment_2d/_segment_3d.
      !! `(i0, j0, nx, ny, nz)` are FILE-side start/count (already resolved
      !! by the caller — plain global-offset slicing for the base
      !! variants, degenerate-axis geometry for the segment variants).
      class(ocean_data_input_t), intent(inout) :: this
      character(len=*), intent(in) :: file, var
      logical, intent(in) :: is_3d
      integer, intent(in) :: i0, j0, nx, ny, nz
      integer, intent(in) :: dest_i0, dest_j0, dest_n1, dest_n2, dest_n3
      character(len=*), intent(in), optional :: time_mode
      real(wp), intent(in), optional :: cycle_period, t_offset, t_scale, scale, add_offset
      integer, intent(in), optional :: oor
      integer, intent(out) :: id
      integer, intent(in), optional :: edge
      integer, intent(out), optional :: ierr
         !! Non-zero (`OCEAN_STATUS_ERR_SETUP`/`OCEAN_STATUS_ERR_IO`) on a
         !! registry/file/dimension failure when present; absent behaves
         !! as today (`error stop`).

      integer :: ncid, varid, tvarid, tdimid, status
      integer :: var_ndims
      integer :: var_dimids(4)
      integer :: expect_nd, d1, d2, dz, dt, nt
      character(len=:), allocatable :: units_str
      logical :: units_ok
      real(wp) :: t_scale_eff
      integer :: k
      integer :: local_ierr

      if (present(ierr)) ierr = OCEAN_STATUS_OK

      if (this%nfields >= this%nfields_max) then
         call fail("ocean_data_input: registry full (max_fields = "// &
                   to_string(this%nfields_max)//"); raise &ocean_data_nml max_fields", &
                   ierr, OCEAN_STATUS_ERR_SETUP)
         return
      end if

      call nc_open_read(trim(file), ncid, ierr=local_ierr)
      if (.not. reg_io_ok(local_ierr, ierr)) return
      call nc_check(nf90_inq_varid(ncid, trim(var), varid), &
                    "ocean_data_input: finding variable '"//trim(var)//"' in "//trim(file), local_ierr)
      if (.not. reg_io_ok(local_ierr, ierr, ncid)) return
      call nc_check(nf90_inquire_variable(ncid, varid, ndims=var_ndims, &
                                          dimids=var_dimids(1:merge(4, 3, is_3d))), &
                    "ocean_data_input: querying variable '"//trim(var)//"'", local_ierr)
      if (.not. reg_io_ok(local_ierr, ierr, ncid)) return

      expect_nd = merge(4, 3, is_3d)
      if (var_ndims /= expect_nd) then
         call nc_close(ncid)
         call fail("ocean_data_input: '"//trim(var)//"' in "//trim(file)// &
                   " has "//to_string(var_ndims)//" dims; expected "// &
                   to_string(expect_nd)//" (x,y[,z],t) — Fortran storage order required, "// &
                   "no in-core transpose (regrid/reorder the file)", ierr, OCEAN_STATUS_ERR_IO)
         return
      end if

      call nc_check(nf90_inquire_dimension(ncid, var_dimids(1), len=d1), &
                    "ocean_data_input: dim 1", local_ierr)
      if (.not. reg_io_ok(local_ierr, ierr, ncid)) return
      call nc_check(nf90_inquire_dimension(ncid, var_dimids(2), len=d2), &
                    "ocean_data_input: dim 2", local_ierr)
      if (.not. reg_io_ok(local_ierr, ierr, ncid)) return
      if (is_3d) then
         call nc_check(nf90_inquire_dimension(ncid, var_dimids(3), len=dz), &
                       "ocean_data_input: dim 3 (z)", local_ierr)
         if (.not. reg_io_ok(local_ierr, ierr, ncid)) return
         call nc_check(nf90_inquire_dimension(ncid, var_dimids(4), len=dt), &
                       "ocean_data_input: dim 4 (t)", local_ierr)
         if (.not. reg_io_ok(local_ierr, ierr, ncid)) return
      else
         dz = 1
         call nc_check(nf90_inquire_dimension(ncid, var_dimids(3), len=dt), &
                       "ocean_data_input: dim 3 (t)", local_ierr)
         if (.not. reg_io_ok(local_ierr, ierr, ncid)) return
      end if

      if (present(edge)) then
         ! Degenerate-axis fail-loud check (§5.7.1): the horizontal
         ! extent this registration claims is 1 (a segment file) must
         ! actually BE 1 in the file.
         if (nx == 1 .and. d1 /= 1) then
            call nc_close(ncid)
            call fail("ocean_data_input: segment '"//trim(var)//"' edge "// &
                      to_string(edge)//" expects a degenerate x axis (extent 1); "// &
                      "file has extent "//to_string(d1), ierr, OCEAN_STATUS_ERR_IO)
            return
         end if
         if (ny == 1 .and. d2 /= 1) then
            call nc_close(ncid)
            call fail("ocean_data_input: segment '"//trim(var)//"' edge "// &
                      to_string(edge)//" expects a degenerate y axis (extent 1); "// &
                      "file has extent "//to_string(d2), ierr, OCEAN_STATUS_ERR_IO)
            return
         end if
      end if

      if (.not. dims_geometry_ok(var_ndims, expect_nd, d1, d2, i0 + nx - 1, j0 + ny - 1)) then
         call nc_close(ncid)
         call fail("ocean_data_input: '"//trim(var)//"' in "//trim(file)// &
                   " horizontal dims too small for this rank's slab: file ("// &
                   to_string(d1)//","//to_string(d2)//"), need offset+extent ("// &
                   to_string(i0 + nx - 1)//","//to_string(j0 + ny - 1)//")", ierr, OCEAN_STATUS_ERR_IO)
         return
      end if
      if (is_3d .and. dz /= nz) then
         call nc_close(ncid)
         call fail("ocean_data_input: '"//trim(var)//"' in "//trim(file)// &
                   " has "//to_string(dz)//" z-levels; caller expects nz_src = "// &
                   to_string(nz), ierr, OCEAN_STATUS_ERR_IO)
         return
      end if

      nt = dt
      if (nt < 1) then
         call nc_close(ncid)
         call fail("ocean_data_input: '"//trim(var)//"' in "//trim(file)//" has no time records", &
                   ierr, OCEAN_STATUS_ERR_IO)
         return
      end if

      ! Time axis: the time DIMENSION and its coordinate VARIABLE share
      ! the CF name by convention; try that, then fall back to "time".
      tdimid = var_dimids(expect_nd)
      call resolve_time_var(ncid, tdimid, tvarid, status)
      if (status /= nf90_noerr) then
         call nc_close(ncid)
         call fail("ocean_data_input: no time coordinate variable found for '"// &
                   trim(var)//"' in "//trim(file), ierr, OCEAN_STATUS_ERR_IO)
         return
      end if

      id = this%nfields + 1
      this%nfields = id
      associate (fld => this%fields(id))
         fld%active = .true.
         fld%ncid = ncid
         fld%varid = varid
         fld%is_3d = is_3d
         fld%nx = nx
         fld%ny = ny
         fld%nz = merge(nz, 1, is_3d)
         fld%i0 = i0
         fld%j0 = j0
         fld%dest_i0 = dest_i0
         fld%dest_j0 = dest_j0
         fld%dest_n1 = dest_n1
         fld%dest_n2 = dest_n2
         fld%dest_n3 = dest_n3
         fld%nt = nt

         fld%scale = 1.0_wp
         if (present(scale)) fld%scale = scale
         fld%add_offset = 0.0_wp
         if (present(add_offset)) fld%add_offset = add_offset
         fld%t_offset = 0.0_wp
         if (present(t_offset)) fld%t_offset = t_offset
         fld%cycle_period = 0.0_wp
         if (present(cycle_period)) fld%cycle_period = cycle_period
         fld%oor = DATA_OOR_ERROR
         if (present(oor)) fld%oor = oor

         fld%time_mode = DATA_TIME_LINEAR
         if (present(time_mode)) fld%time_mode = data_input_time_mode_from_string(time_mode)
         if (fld%time_mode == DATA_TIME_CYCLIC .and. fld%cycle_period <= 0.0_wp) then
            fld%active = .false.
            this%nfields = this%nfields - 1
            call nc_close(ncid)
            call fail("ocean_data_input: '"//trim(var)//"' time_mode='cyclic' requires "// &
                      "cycle_period > 0", ierr, OCEAN_STATUS_ERR_SETUP)
            return
         end if

         allocate (fld%t_axis(nt))
         call nc_get_var_1d(ncid, tvarid, fld%t_axis)

         t_scale_eff = 1.0_wp
         if (present(t_scale)) then
            t_scale_eff = t_scale
         else
            call nc_get_att_text(ncid, tvarid, "units", units_str, units_ok)
            if (units_ok) then
               call data_input_time_scale_from_units(trim(units_str), t_scale_eff, units_ok)
            end if
            ! units_ok = .false. (absent/unrecognised attribute) silently
            ! keeps the seconds-default — the common case for a
            ! model-native file with no CF units attribute.
         end if
         fld%t_axis = fld%t_axis*t_scale_eff

         do k = 2, nt
            if (fld%t_axis(k) <= fld%t_axis(k - 1)) then
               call logger%error("ocean_data_input: '"//trim(var)//"' time axis not "// &
                                 "monotonically increasing at record "//to_string(k)//" ("// &
                                 to_string(fld%t_axis(k))//" <= "//to_string(fld%t_axis(k - 1))//")")
               error stop "ocean_data_input: non-monotonic time axis"
            end if
         end do

         allocate (fld%f0(fld%nx, fld%ny, fld%nz))
         allocate (fld%f1(fld%nx, fld%ny, fld%nz))

         if (fld%time_mode == DATA_TIME_STATIC) then
            call data_input_read_slab_impl(fld, 1)
            fld%f1 = fld%f0
            fld%rec0 = 1
            fld%rec1 = 1
            fld%w = 0.0_wp
         end if
      end associate
   end subroutine register_common