diff --git a/Makefile.am b/Makefile.am index 849ee3891..7d5725931 100644 --- a/Makefile.am +++ b/Makefile.am @@ -43,6 +43,7 @@ SUBDIRS = \ fms2_io \ mosaic2 \ fms \ + offloading \ parser \ string_utils \ affinity \ diff --git a/configure.ac b/configure.ac index 791f1ca19..c4bfec3c4 100644 --- a/configure.ac +++ b/configure.ac @@ -520,6 +520,7 @@ AC_CONFIG_FILES([ diag_integral/Makefile sat_vapor_pres/Makefile random_numbers/Makefile + offloading/Makefile libFMS/Makefile docs/Makefile parser/Makefile @@ -554,6 +555,7 @@ AC_CONFIG_FILES([ test_fms/random_numbers/Makefile test_fms/topography/Makefile test_fms/column_diagnostics/Makefile + test_fms/offloading/Makefile test_fms/block_control/Makefile FMS.pc ]) diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 9a4836a92..be65205ee 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -29,6 +29,7 @@ module netcdf_io_mod #endif use netcdf use mpp_mod +use mpp_domains_mod use fms_io_utils_mod use platform_mod implicit none @@ -122,6 +123,17 @@ module netcdf_io_mod !! cur_dim_len(3) : z dimensions endtype dimension_information +type, public :: fmsOffloadingIn_type + !TODO should be private, need getter functions + integer, public :: id !< unique identifier for each type + integer, public, allocatable :: offloading_pes(:) !< list of pe numbers that will be used to just write + integer, public, allocatable :: model_pes(:) !< list of pe numbers that will be running the model + logical :: is_model_pe !< true if current pe is in model_pes + type(domain2D) :: domain_in !< domain for grid that is to be written out + contains + procedure :: init +endtype fmsOffloadingIn_type + !> @brief Netcdf file type. !> @ingroup netcdf_io_mod type, public :: FmsNetcdfFile_t @@ -148,12 +160,13 @@ module netcdf_io_mod character (len=20) :: time_name type(dimension_information) :: bc_dimensions ! Initialization routine for fmsOffloadingIn_type +subroutine init(this, offloading_obj_id, offloading_pes, model_pes, domain) + class(fmsOffloadingIn_type), intent(inout) :: this !< offloading object to initialize + integer, intent(in) :: offloading_obj_id !< unique id number to set + integer, intent(in) :: offloading_pes(:) !< list of pe's from current list to offload writes to + integer, intent(in) :: model_pes(:) !< list of model pe's (any pes not in offloading_pes argument) + type(domain2D) :: domain + + this%id = offloading_obj_id + allocate(this%offloading_pes(size(offloading_pes))) + this%offloading_pes = offloading_pes + allocate(this%model_pes(size(model_pes))) + this%model_pes = model_pes + + this%is_model_pe = .false. + if (any(model_pes .eq. mpp_pe())) & + this%is_model_pe = .true. + this%domain_in = domain +end subroutine !> @brief Getter for use_netcdf_mpi pure logical function is_file_using_netcdf_mpi(this) class(FmsNetcdfFile_t), intent(in) :: this !< fms2io fileobj to query diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index 5c1835c95..d39b16613 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -63,6 +63,7 @@ libFMS_la_LIBADD += $(top_builddir)/diag_integral/libdiag_integral.la libFMS_la_LIBADD += $(top_builddir)/sat_vapor_pres/libsat_vapor_pres.la libFMS_la_LIBADD += $(top_builddir)/parser/libparser.la libFMS_la_LIBADD += $(top_builddir)/string_utils/libstring_utils.la +libFMS_la_LIBADD += $(top_builddir)/offloading/liboffload.la libFMS_la_LIBADD += $(top_builddir)/libFMS_mod.la libFMS_la_SOURCES = diff --git a/offloading/Makefile.am b/offloading/Makefile.am new file mode 100644 index 000000000..3ec20a027 --- /dev/null +++ b/offloading/Makefile.am @@ -0,0 +1,44 @@ +#*********************************************************************** +#* Apache License 2.0 +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* Licensed under the Apache License, Version 2.0 (the "License"); +#* you may not use this file except in compliance with the License. +#* You may obtain a copy of the License at +#* +#* http://www.apache.org/licenses/LICENSE-2.0 +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +#* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +#* PARTICULAR PURPOSE. See the License for the specific language +#* governing permissions and limitations under the License. +#*********************************************************************** +# This is an automake file for the offloading directory of the FMS +# package. + +# Ryan Mulhall 2025 + +# Include .h and .mod files. +AM_CPPFLAGS = -I$(top_srcdir)/include +AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) + +# Build this uninstalled convenience library. +noinst_LTLIBRARIES = liboffload.la + +# The convenience library depends on its source. +liboffload_la_SOURCES = \ + metadata_transfer.F90 \ + offloading_io.F90 + +MODFILES = \ + metadata_transfer_mod.$(FC_MODEXT) \ + offloading_io_mod.$(FC_MODEXT) + +offloading_io_mod.$(FC_MODEXT): metadata_transfer_mod.$(FC_MODEXT) + +BUILT_SOURCES = $(MODFILES) +nodist_include_HEADERS = $(MODFILES) + +include $(top_srcdir)/mkmods.mk diff --git a/offloading/metadata_transfer.F90 b/offloading/metadata_transfer.F90 new file mode 100644 index 000000000..a484b94d7 --- /dev/null +++ b/offloading/metadata_transfer.F90 @@ -0,0 +1,322 @@ +!*********************************************************************** +!* Apache License 2.0 +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* Licensed under the Apache License, Version 2.0 (the "License"); +!* you may not use this file except in compliance with the License. +!* You may obtain a copy of the License at +!* +!* http://www.apache.org/licenses/LICENSE-2.0 +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +!* PARTICULAR PURPOSE. See the License for the specific language +!* governing permissions and limitations under the License. +!*********************************************************************** +module metadata_transfer_mod + use platform_mod +#ifdef use_libMPI + use mpi, only: MPI_Type_create_struct, MPI_Type_commit, MPI_INTEGER, MPI_CHARACTER, & + MPI_DOUBLE, MPI_FLOAT, MPI_INT, MPI_LONG_INT, MPI_SUCCESS, MPI_ADDRESS_KIND +#endif + use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_error, FATAL, mpp_get_current_pelist, mpp_npes + use fms_mod, only: string + + implicit none + + public + +#ifdef use_libMPI + external MPI_Bcast +#endif + + integer, parameter :: real8_type = 1 !< enumeration for real(kind=8) data type + integer, parameter :: real4_type = 2 !< enumeration for real(kind=4) data type + integer, parameter :: int8_type = 3 !< enumeration for integer(kind=8) data type + integer, parameter :: int4_type = 4 !< enumeration for integer(kind=4) data type + integer, parameter :: str_type = 5 !< enumeration for string data type + + integer, parameter :: ATTR_NAME_MAX_LENGTH = 128 + integer, parameter :: ATTR_VALUE_MAX_LENGTH = 128 + + !> Base class for broadcasting netcdf attribute data as a struct, holds the common fields + !! and routines for initializing the mpi datatype so that children classes can + !! be broadcasted. + type, abstract :: metadata_class + private + integer :: mpi_type_id = -1 !< MPI datatype id corresponding to this data objects data + !! -1 if not set + integer :: attribute_length = -1 !< length of the attribute value array, -1 if not set + character(len=ATTR_NAME_MAX_LENGTH) :: attribute_name !< name of the attribute to write + contains + procedure :: fms_metadata_broadcast + procedure :: fms_metadata_transfer_init + procedure :: get_attribute_name + procedure :: set_attribute_name + end type + + + !> Metadata class for real(kind=8) attribute values + type, extends(metadata_class) :: metadata_r8_type + real(r8_kind) :: attribute_value(ATTR_VALUE_MAX_LENGTH) + contains + procedure :: get_attribute_value => get_attribute_r8_value + procedure :: set_attribute_value => set_attribute_r8_value + end type metadata_r8_type + + !> Metadata class for real(kind=4) attribute values + type, extends(metadata_class) :: metadata_r4_type + real(r4_kind) :: attribute_value(ATTR_VALUE_MAX_LENGTH) + contains + procedure :: get_attribute_value => get_attribute_r4_value + procedure :: set_attribute_value => set_attribute_r4_value + end type metadata_r4_type + + !> Metadata class for integer(kind=8) attribute values + type, extends(metadata_class) :: metadata_i8_type + integer(i8_kind) :: attribute_value(ATTR_VALUE_MAX_LENGTH) + contains + procedure :: get_attribute_value => get_attribute_i8_value + procedure :: set_attribute_value => set_attribute_i8_value + end type metadata_i8_type + + !> Metadata class for integer(kind=4) attribute values + type, extends(metadata_class) :: metadata_i4_type + integer(i4_kind) :: attribute_value(ATTR_VALUE_MAX_LENGTH) + contains + procedure :: get_attribute_value => get_attribute_i4_value + procedure :: set_attribute_value => set_attribute_i4_value + end type metadata_i4_type + + !> Metadata class for string attribute values + type, extends(metadata_class) :: metadata_str_type + character(len=ATTR_VALUE_MAX_LENGTH) :: attribute_value + contains + procedure :: get_attribute_value => get_attribute_str_value + procedure :: set_attribute_value => set_attribute_str_value + end type metadata_str_type + + contains + + !> Initialize the mpi datatype for future broadcasts + !! The metadata object's functions (not subroutines) are stored as fields in memory, + !! so they need to be included in the MPI struct declaration. + subroutine fms_metadata_transfer_init(this, dtype) + class(metadata_class), intent(inout) :: this ! Broadcast the entire metadata object to all PEs in the current pelist + subroutine fms_metadata_broadcast(this) + class(metadata_class), intent(inout) :: this !< object that inherits metadata_class + integer :: ierror, curr_comm_id + integer, allocatable :: broadcasting_pes(:) + if (this%mpi_type_id .eq. -1) then + call mpp_error(FATAL, "fms_metadata_broadcast: metadata_transfer not initialized") + end if + + allocate(broadcasting_pes(mpp_npes())) + call mpp_get_current_pelist(broadcasting_pes, commID=curr_comm_id) + +#ifdef use_libMPI + ! Broadcast the metadata transfer type to all processes + select type(this) + type is (metadata_r8_type) + call MPI_Bcast(this, 1, this%mpi_type_id, mpp_root_pe(), curr_comm_id, ierror) + type is (metadata_r4_type) + call MPI_Bcast(this, 1, this%mpi_type_id, mpp_root_pe(), curr_comm_id, ierror) + type is (metadata_i4_type) + call MPI_Bcast(this, 1, this%mpi_type_id, mpp_root_pe(), curr_comm_id, ierror) + type is (metadata_i8_type) + call MPI_Bcast(this, 1, this%mpi_type_id, mpp_root_pe(), curr_comm_id, ierror) + type is (metadata_str_type) + call MPI_Bcast(this, 1, this%mpi_type_id, mpp_root_pe(), curr_comm_id, ierror) + end select + if (ierror /= MPI_SUCCESS) then + call mpp_error(FATAL, "fms_metadata_broadcast: MPI_Bcast failed") + end if +#else + call mpp_error(FATAL, "fms_metadata_broadcast: MPI library not enabled") +#endif + + + end subroutine fms_metadata_broadcast + + !> Broadcast an array of metadata objects to all PEs in the current pelist + subroutine fms_metadata_broadcast_all(metadata_objs) + class(metadata_class), intent(inout) :: metadata_objs(:) !< list of metadata objects + integer :: i + + do i=1, size(metadata_objs) + if (metadata_objs(i)%mpi_type_id .eq. -1) then + call mpp_error(FATAL, "fms_metadata_broadcast_all: metadata_transfer not initialized") + end if + call metadata_objs(i)%fms_metadata_broadcast() + enddo + + end subroutine fms_metadata_broadcast_all + + !> Getter for real 8 attribute_value + function get_attribute_r8_value(this) result(val) + class(metadata_r8_type), intent(inout) :: this + real(r8_kind), allocatable :: val(:) + val = this%attribute_value(1:this%attribute_length) + end function + + !> Setter for real 8 attribute_value + subroutine set_attribute_r8_value(this, val) + class(metadata_r8_type), intent(inout) :: this + real(r8_kind), intent(in) :: val(:) !< 8 byte real value to set attribute value to + if(size(val) .gt. ATTR_VALUE_MAX_LENGTH) then + call mpp_error(FATAL, & + "metadata_transfer_mod: attribute value array exceeds max length of "//string(ATTR_NAME_MAX_LENGTH)) + endif + this%attribute_length = size(val) + this%attribute_value(1:size(val)) = val + end subroutine + + !> Getter for real 4 attribute_value + function get_attribute_r4_value(this) result(val) + class(metadata_r4_type), intent(inout) :: this + real(r4_kind), allocatable :: val(:) + val = this%attribute_value(1:this%attribute_length) + end function + + !> Setter for real 4 attribute_value + subroutine set_attribute_r4_value(this, val) + class(metadata_r4_type), intent(inout) :: this + real(r4_kind), intent(in) :: val(:) !< 4 byte real attribute to set + if(size(val) .gt. ATTR_VALUE_MAX_LENGTH) then + call mpp_error(FATAL, & + "metadata_transfer_mod: attribute value array exceeds max length of "//string(ATTR_NAME_MAX_LENGTH)) + endif + this%attribute_length = size(val) + this%attribute_value(1:size(val)) = val + end subroutine + + !> Getter for integer(kind=8) attribute_value + function get_attribute_i8_value(this) result(val) + class(metadata_i8_type), intent(inout) :: this + integer(i8_kind), allocatable :: val(:) + val = this%attribute_value(1:this%attribute_length) + end function + + !> Setter for integer(kind=8) attribute_value + subroutine set_attribute_i8_value(this, val) + class(metadata_i8_type), intent(inout) :: this + integer(i8_kind), intent(in) :: val(:) !< 8 byte int attribute to set + if(size(val) .gt. ATTR_VALUE_MAX_LENGTH) then + call mpp_error(FATAL, & + "metadata_transfer_mod: attribute value array exceeds max length of "//string(ATTR_NAME_MAX_LENGTH)) + endif + this%attribute_length = size(val) + this%attribute_value(1:size(val)) = val + end subroutine + + !> Getter for integer(kind=4) attribute_value + function get_attribute_i4_value(this) result(val) + class(metadata_i4_type), intent(inout) :: this + integer(i4_kind), allocatable :: val(:) + val = this%attribute_value(1:this%attribute_length) + end function + + !> Setter for integer(kind=4) attribute_value + subroutine set_attribute_i4_value(this, val) + class(metadata_i4_type), intent(inout) :: this + integer(i4_kind), intent(in) :: val(:) !< 4 byte integer to set attribute value to + if(size(val) .gt. ATTR_VALUE_MAX_LENGTH) then + call mpp_error(FATAL, & + "metadata_transfer_mod: attribute value array exceeds max length of "//string(ATTR_NAME_MAX_LENGTH)) + endif + this%attribute_length = size(val) + this%attribute_value(1:size(val)) = val + end subroutine + + !> Getter for string attribute_value + function get_attribute_str_value(this) result(val) + class(metadata_str_type), intent(inout) :: this + character(len=:), allocatable :: val + val = this%attribute_value(1:this%attribute_length) + end function + + !> Setter for string attribute_value + subroutine set_attribute_str_value(this, val) + class(metadata_str_type), intent(inout) :: this + character(len=*), intent(in) :: val !< character string to set attribute value to + if(len(val) .gt. ATTR_VALUE_MAX_LENGTH) then + call mpp_error(FATAL, & + "metadata_transfer_mod: attribute value array exceeds max length of "//string(ATTR_NAME_MAX_LENGTH)) + endif + this%attribute_length = len(val) + this%attribute_value(1:len(val)) = val + end subroutine + + !> Getter for attribute_name (for all metadata types) + function get_attribute_name(this) result(val) + class(metadata_class), intent(inout) :: this + character(len=ATTR_NAME_MAX_LENGTH) :: val + val = trim(this%attribute_name) + end function + + !> Setter for attribute_name (for all metadata types) + subroutine set_attribute_name(this, val) + class(metadata_class), intent(inout) :: this + character(len=*), intent(in) :: val !< character string to set attribute name to + if(len(val) .gt. ATTR_NAME_MAX_LENGTH) then + call mpp_error(FATAL, & + "metadata_transfer_mod: attribute name exceeds max length of "//string(ATTR_VALUE_MAX_LENGTH)) + endif + this%attribute_name = val + end subroutine + +end module metadata_transfer_mod diff --git a/offloading/offloading_io.F90 b/offloading/offloading_io.F90 new file mode 100644 index 000000000..74dadc15d --- /dev/null +++ b/offloading/offloading_io.F90 @@ -0,0 +1,972 @@ +!*********************************************************************** +!* Apache License 2.0 +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* Licensed under the Apache License, Version 2.0 (the "License"); +!* you may not use this file except in compliance with the License. +!* You may obtain a copy of the License at +!* +!* http://www.apache.org/licenses/LICENSE-2.0 +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +!* PARTICULAR PURPOSE. See the License for the specific language +!* governing permissions and limitations under the License. +!*********************************************************************** +module offloading_io_mod + use mpp_mod + use mpp_domains_mod + use fms_string_utils_mod, only: string + use fms2_io_mod + use metadata_transfer_mod + use platform_mod + use fms_mod + + implicit none + + integer :: current_files_init !< number of currently initialized offloading files + logical :: module_is_initialized !< .true. if module has been initialized + + integer :: max_files = 10 !< amount of offloaded files to allocate space for + + namelist / offloading_io_nml / max_files + + !> Structure to hold offloading file information + type :: offloading_obj_out + integer :: id + character(len=:), allocatable :: filename !< filename of the offloaded netcdf file + class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object + type(domain2D) :: domain_out !< domain on offloading PEs + end type + + !> Offload equivalent of register_axis in fms2_io_mod + !! Registers an axis to a netcdf file on offloaded PEs. File must have been opened with open_file_offload. + !! TODO: add register_unstructured_axis_offload for the unstructured grid + interface register_axis_offload + procedure :: register_netcdf_axis_offload + procedure :: register_domain_axis_offload + end interface + + !> Offload equivalent of write_data in fms2_io_mod + !! Writes data to a netcdf file on offloaded PEs. File must have been opened with open_file_offload. + interface write_data_offload + procedure :: write_data_offload_2d + procedure :: write_data_offload_3d + end interface + + !> Array of offloading objects that have been initialized by this module. + type(offloading_obj_out), allocatable, target :: offloading_objs(:) + + private + + public :: offloading_io_init, open_file_offload + public :: global_metadata_offload, close_file_offload, register_axis_offload, register_field_offload + public :: write_data_offload + public :: create_cubic_domain, create_lat_lon_domain + + contains + + !> Initialize by allocating array used to keep track of offloading file objects. + subroutine offloading_io_init() + integer :: ierr, io + if (module_is_initialized) return + current_files_init = 0 + allocate(offloading_objs(max_files)) + module_is_initialized = .true. + read (input_nml_file, offloading_io_nml, iostat=io) + ierr = check_nml_error(io,'offloading_io_nml') + end subroutine offloading_io_init + + !> Open a netcdf file and set it up for offloaded writes + !! This routine should be called from both the model PEs and the offload PEs, with the full list + !! of pes for each group being provided. The model PEs will broadcast the filename and domain. + subroutine open_file_offload(fileobj, filename, domain_in, pe_in, pe_out) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !< fms2_io file object + character(len=*), intent(in) :: filename !< filename to open + type(domain2D), intent(inout) :: domain_in !< model domain (from model pes) + integer, intent(in) :: pe_in(:) !< model pes + integer, intent(in) :: pe_out(:) !< offload pes + + integer, parameter :: str_len = 255 + character(len=str_len) :: filename_out(1) + integer :: object_id + integer :: global_domain_size(2) + integer :: ntile + integer, allocatable :: all_current_pes(:) + integer, allocatable :: broadcasting_pes(:) + logical :: is_pe_out + + is_pe_out = ANY(pe_out .eq. mpp_pe()) + + ! This should be called from the model PEs and the offload PEs + if (.not. module_is_initialized) & + call mpp_error(FATAL, "offloading_io_mod is not initialized") + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + filename_out(1) = "" + if (mpp_pe() .eq. pe_in(1)) then + !< The root model pe gets the domain info (ntiles and size of global domain) + ntile = mpp_get_ntile_count(domain_in) + + !< The number of tiles must be the same as the number of offloading pes + if ( MOD(size(pe_out), ntile) .ne. 0 ) & + call mpp_error(FATAL, "The number of offloading PEs must be the same as the number of tiles of the domain") + filename_out(1) = filename + + call mpp_get_global_domain(domain_in, xsize=global_domain_size(1), ysize=global_domain_size(2)) + endif + + ! A "Root" model PE broadcasts the filename, domain size, and number of tiles to the offload pes + if (mpp_pe() .eq. pe_in(1) .or. is_pe_out) then + allocate(broadcasting_pes(1 + size(pe_out))) + broadcasting_pes(1) = pe_in(1) ! root pe + broadcasting_pes(2:size(broadcasting_pes)) = pe_out ! offload pes + call mpp_set_current_pelist( broadcasting_pes ) + ! TODO bundle these into a single derived type to reduce the number of broadcasts + call mpp_broadcast(filename_out, str_len, pe_in(1)) + call mpp_broadcast(global_domain_size, size(global_domain_size), pe_in(1)) + call mpp_broadcast(ntile, pe_in(1)) + endif + + ! Broadcast the domain + call mpp_set_current_pelist(all_current_pes) + if (is_pe_out) call mpp_define_null_domain(domain_in) + call mpp_broadcast_domain(domain_in) + + ! The offload pes inits the offloading object and return an object id + if (is_pe_out) then + call mpp_set_current_pelist(pe_out) + object_id = init_offloading_object(filename_out(1), global_domain_size(1), global_domain_size(2),& + ntile) + endif + call mpp_set_current_pelist(all_current_pes) + call mpp_broadcast(object_id, pe_out(1)) + + ! Init the "offloading object" in the fileobj + call fileobj%offloading_obj_in%init(object_id, pe_out, pe_in, domain_in) + end subroutine open_file_offload + + !> Broadcast and register a global metadata attribute on offloading PEs + subroutine global_metadata_offload(fileobj, attribute_name, attribute_value) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !< fms2_io file object + character(len=*), intent(in) :: attribute_name !< name of the global attribute to register + class(*), intent(in) :: attribute_value !< value of the global attribute to register (r4, r8, i4, i8, str) + + integer :: id + type(offloading_obj_out), pointer :: this + + !TODO better PEs management! + integer, allocatable :: offloading_pes(:) + integer, allocatable :: model_pes(:) + integer, allocatable :: all_current_pes(:) + integer, allocatable :: broadcasting_pes(:) + logical :: is_model_pe + character(len=255) :: att_name(1) + + integer :: int_buf + real(r4_kind), allocatable :: r4_tmp(:) + real(r8_kind), allocatable :: r8_tmp(:) + integer(i4_kind) , allocatable :: i4_tmp(:) + integer(i8_kind) , allocatable :: i8_tmp(:) + character(len=:), allocatable :: str_tmp + class(metadata_class), allocatable :: transfer_obj + + select type (attribute_value) + type is (real(kind=r8_kind)) + allocate(metadata_r8_type :: transfer_obj) + call transfer_obj%fms_metadata_transfer_init(real8_type) + type is (real(kind=r4_kind)) + allocate(metadata_r4_type :: transfer_obj) + call transfer_obj%fms_metadata_transfer_init(real4_type) + type is (integer(kind=i4_kind)) + allocate(metadata_i4_type :: transfer_obj) + call transfer_obj%fms_metadata_transfer_init(int4_type) + type is (integer(kind=i8_kind)) + allocate(metadata_i8_type :: transfer_obj) + call transfer_obj%fms_metadata_transfer_init(int8_type) + type is (character(*)) + allocate(metadata_str_type :: transfer_obj) + call transfer_obj%fms_metadata_transfer_init(str_type) + class default + call mpp_error(FATAL, "Unsupported attribute type for offloading: " // string(attribute_value)) + end select + + offloading_pes = fileobj%offloading_obj_in%offloading_pes + model_pes = fileobj%offloading_obj_in%model_pes + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + + if (is_model_pe) then + att_name(1) = attribute_name + call transfer_obj%set_attribute_name(attribute_name) + endif + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + if (mpp_pe() .eq. model_pes(1) .or. .not. is_model_pe) then + + allocate(broadcasting_pes(1 + size(offloading_pes))) + broadcasting_pes(1) = model_pes(1) + broadcasting_pes(2:size(broadcasting_pes)) = offloading_pes + call mpp_set_current_pelist( broadcasting_pes ) + + select type (attribute_value) + type is (real(kind=r4_kind)) + ! TODO replace this mess with a single call if possible + if (is_model_pe) then + select type(transfer_obj) + type is (metadata_r4_type) + call transfer_obj%set_attribute_value([attribute_value]) + end select + endif + call transfer_obj%fms_metadata_broadcast() + select type(transfer_obj) + type is (metadata_r4_type) + r4_tmp = transfer_obj%get_attribute_value() + end select + att_name(1) = transfer_obj%get_attribute_name() + if (.not. is_model_pe) then + call register_global_attribute(this%fileobj, att_name(1), r4_tmp) + endif + + type is (real(kind=r8_kind)) + ! TODO replace this mess with a single call if possible + if (is_model_pe) then + select type(transfer_obj) + type is (metadata_r8_type) + call transfer_obj%set_attribute_value([attribute_value]) + end select + endif + call transfer_obj%fms_metadata_broadcast() + select type(transfer_obj) + type is (metadata_r8_type) + r8_tmp = transfer_obj%get_attribute_value() + end select + att_name(1) = transfer_obj%get_attribute_name() + if (.not. is_model_pe) then + call register_global_attribute(this%fileobj, att_name(1), r8_tmp) + endif + + type is (integer(kind=i4_kind)) + if (is_model_pe) then + select type(transfer_obj) + type is (metadata_i4_type) + call transfer_obj%set_attribute_value([attribute_value]) + int_buf = attribute_value + end select + endif + call transfer_obj%fms_metadata_broadcast() + select type(transfer_obj) + type is (metadata_i4_type) + i4_tmp = transfer_obj%get_attribute_value() + end select + att_name(1) = transfer_obj%get_attribute_name() + if (.not. is_model_pe) then + call register_global_attribute(this%fileobj, att_name(1), i4_tmp) + endif + + type is (integer(kind=i8_kind)) + ! TODO replace this mess with a single call if possible + if (is_model_pe) then + select type(transfer_obj) + type is (metadata_i8_type) + call transfer_obj%set_attribute_value([attribute_value]) + end select + endif + call transfer_obj%fms_metadata_broadcast() + select type(transfer_obj) + type is (metadata_i8_type) + i8_tmp = transfer_obj%get_attribute_value() + end select + att_name(1) = transfer_obj%get_attribute_name() + if (.not. is_model_pe) then + call register_global_attribute(this%fileobj, att_name(1), i8_tmp) + endif + + type is (character(len=*)) + ! TODO replace this mess with a single call if possible + if (is_model_pe) then + select type(transfer_obj) + type is (metadata_str_type) + call transfer_obj%set_attribute_value(attribute_value) + end select + endif + call transfer_obj%fms_metadata_broadcast() + select type(transfer_obj) + type is (metadata_str_type) + str_tmp = transfer_obj%get_attribute_value() + end select + att_name(1) = transfer_obj%get_attribute_name() + if (.not. is_model_pe) then + call register_global_attribute(this%fileobj, att_name(1), str_tmp) + endif + + end select + endif + + call mpp_set_current_pelist(all_current_pes) + end subroutine + + !> Register a domain axis (ie. x or y) on offloading PEs + subroutine register_domain_axis_offload(fileobj, axis_name, cart) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !< fms2_io file object + character(len=*), intent(in) :: axis_name !< axis name to be written to file + character(len=1), intent(in) :: cart !< must be either 'x' or 'y' for cartesian axis + + integer :: id + type(offloading_obj_out), pointer :: this + + integer, allocatable :: offloading_pes(:) + integer, allocatable :: model_pes(:) + integer, allocatable :: all_current_pes(:) + integer, allocatable :: broadcasting_pes(:) + logical :: is_model_pe + character(len=ATTR_NAME_MAX_LENGTH) :: var_info(2) + + offloading_pes = fileobj%offloading_obj_in%offloading_pes + model_pes = fileobj%offloading_obj_in%model_pes + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + + if (is_model_pe) then + var_info(1) = axis_name + var_info(2) = cart + endif + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + if (mpp_pe() .eq. model_pes(1) .or. .not. is_model_pe) then + allocate(broadcasting_pes(1 + size(offloading_pes))) + broadcasting_pes(1) = model_pes(1) + broadcasting_pes(2:size(broadcasting_pes)) = offloading_pes + call mpp_set_current_pelist( broadcasting_pes ) + call mpp_broadcast(var_info, 255, model_pes(1)) + endif + + if (.not. is_model_pe) then + select type(file=>this%fileobj) + type is(FmsNetcdfDomainFile_t) + call register_axis(file, trim(var_info(1)), trim(var_info(2))) + class default + call mpp_error(FATAL, & + "offloading_io_mod::register_domain_axis_offload currently only supports FmsNetcdfDomainFile_t") + end select + endif + + call mpp_set_current_pelist(all_current_pes) + end subroutine register_domain_axis_offload + + !> Register a netcdf axis on offloading PEs + subroutine register_netcdf_axis_offload(fileobj, axis_name, length) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !< fms2_io file object + character(len=*), intent(in) :: axis_name !< axis name to be written to file + integer, intent(in) :: length !< length of the axis + + integer :: id + type(offloading_obj_out), pointer :: this + + !TODO better PEs management! + integer, allocatable :: offloading_pes(:) + integer, allocatable :: model_pes(:) + integer, allocatable :: all_current_pes(:) + integer, allocatable :: broadcasting_pes(:) + logical :: is_model_pe + character(len=255) :: var_axis(1) + integer :: var_length + integer :: axis_length + + offloading_pes = fileobj%offloading_obj_in%offloading_pes + model_pes = fileobj%offloading_obj_in%model_pes + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + + ! get var data on root for broadcasting to offload pes + if (mpp_pe() .eq. model_pes(1)) then + var_axis(1) = trim(axis_name) + axis_length = len_trim(var_axis(1)) + var_length = length + endif + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + ! root pe broadcasts the axis name and length to offload pes + if (mpp_pe() .eq. model_pes(1) .or. .not. is_model_pe) then + allocate(broadcasting_pes(1 + size(offloading_pes))) + broadcasting_pes(1) = model_pes(1) + broadcasting_pes(2:size(broadcasting_pes)) = offloading_pes + call mpp_set_current_pelist( broadcasting_pes ) + ! TODO bundle these into a single derived type to reduce the number of broadcasts + call mpp_broadcast(axis_length, model_pes(1)) + call mpp_broadcast(var_axis, axis_length, model_pes(1)) + call mpp_broadcast(var_length, model_pes(1)) + endif + + if (.not. is_model_pe) then + select type(wut=>this%fileobj) + type is(FmsNetcdfDomainFile_t) + call register_axis(this%fileobj, var_axis(1)(1:axis_length), var_length) + class default + call mpp_error(FATAL, & + "offloading_io_mod::register_netcdf_axis_offload currently only supports FmsNetcdfDomainFile_t") + end select + endif + + call mpp_set_current_pelist(all_current_pes) + end subroutine register_netcdf_axis_offload + + !> Register a netcdf field on offloading PEs + subroutine register_field_offload(fileobj, varname, vartype, dimensions) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !> fms2_io file object + character(len=*), intent(in) :: varname !> name of the variable to be registered + character(len=*), intent(in) :: vartype !> type of the variable to be registered + !! must be one of {r4_type, r8_type, i4_type, i8_type, str_type} + character(len=*), intent(in) :: dimensions(:) !< previously registered dimension/axis names for the variable + + integer :: id + type(offloading_obj_out), pointer :: this + integer :: ndim + + !TODO better PEs management! + integer, allocatable :: offloading_pes(:) + integer, allocatable :: model_pes(:) + integer, allocatable :: all_current_pes(:) + integer, allocatable :: broadcasting_pes(:) + logical :: is_model_pe + character(len=255), allocatable :: var_info(:) + + offloading_pes = fileobj%offloading_obj_in%offloading_pes + model_pes = fileobj%offloading_obj_in%model_pes + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + if (is_model_pe) then + ndim = size(dimensions) + + allocate(var_info(ndim + 2)) + var_info(1) = varname + var_info(2) = vartype + var_info(3:) = dimensions + + endif + + if (mpp_pe() .eq. model_pes(1) .or. .not. is_model_pe) then + allocate(broadcasting_pes(1 + size(offloading_pes))) + broadcasting_pes(1) = model_pes(1) + broadcasting_pes(2:size(broadcasting_pes)) = offloading_pes + call mpp_set_current_pelist( broadcasting_pes ) + call mpp_broadcast(ndim, model_pes(1)) + + if (.not. is_model_pe) allocate(var_info(ndim + 2)) + call mpp_broadcast(var_info, 255, model_pes(1)) + endif + + if (.not. is_model_pe) then + !select type(wut=>this%fileobj) + ! type is(FmsNetcdfDomainFile_t) + call register_field(this%fileobj, trim(var_info(1)), trim(var_info(2)), var_info(3:)) + !end select + endif + + call mpp_set_current_pelist(all_current_pes) + end subroutine + + !> Write 3D data to offloaded netcdf file + subroutine write_data_offload_3d(fileobj, varname, vardata, unlim_dim_level) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !< fms2_io file object + character(len=*), intent(in) :: varname !< name of the variable to be written + real(kind=r4_kind), intent(in) :: vardata(:,:,:) !< 3D data to be written + integer, intent(in), optional :: unlim_dim_level !< level along unlimited dimension to write to + + integer :: id + type(offloading_obj_out), pointer :: this + + !TODO better PEs management! + integer, allocatable :: offloading_pes(:) + integer, allocatable :: model_pes(:) + integer, allocatable :: all_current_pes(:) + logical :: is_model_pe + + real(kind=r4_kind), allocatable :: var_r4_data(:,:,:) + type(domain2D) :: domain_out + type(domain2D) :: domain_in + integer :: isc, iec, jsc, jec, nz, redistribute_clock + character(len=ATTR_NAME_MAX_LENGTH) :: varname_tmp(1) + + offloading_pes = fileobj%offloading_obj_in%offloading_pes + model_pes = fileobj%offloading_obj_in%model_pes + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + redistribute_clock = mpp_clock_id( 'data_transfer' ) + call mpp_clock_begin(redistribute_clock) + + nz = size(vardata, 3) + call mpp_broadcast(nz, model_pes(1)) + + !Allocate space to store the data! + if (.not. is_model_pe) then + domain_out = this%domain_out + call mpp_get_data_domain(domain_out, isc, iec, jsc, jec) + allocate(var_r4_data(isc:iec, jsc:jec, nz)) + call mpp_define_null_domain(domain_in) + else + domain_in = fileobj%offloading_obj_in%domain_in + call mpp_define_null_domain(domain_out) + endif + + ! get domain from the other pes + call mpp_broadcast_domain(domain_out) + call mpp_broadcast_domain(domain_in) + + call mpp_redistribute( domain_in, vardata, domain_out, var_r4_data) + call mpp_redistribute( domain_in, vardata, domain_out, var_r4_data, free=.true.) + + if(mpp_pe() .eq. model_pes(1)) then + varname_tmp(1) = trim(varname) + endif + call mpp_broadcast(varname_tmp, 255, model_pes(1)) + + call mpp_clock_end(redistribute_clock) + + if (.not. is_model_pe) then + select type(wut=>this%fileobj) + type is(FmsNetcdfDomainFile_t) + if (present(unlim_dim_level)) then + call write_data(wut, varname, var_r4_data, unlim_dim_level=unlim_dim_level) + else + call write_data(wut, varname, var_r4_data) + endif + end select + endif + call mpp_set_current_pelist(all_current_pes) + end subroutine write_data_offload_3d + + !> Write 2D data to offloaded netcdf file + subroutine write_data_offload_2d(fileobj, varname, vardata) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !< fms2_io file object + character(len=*), intent(in) :: varname !< name of the variable to be written + real(kind=r4_kind), intent(in) :: vardata(:,:) !< 2D data to be written + + integer :: id + type(offloading_obj_out), pointer :: this + + !TODO better PEs management! + integer, allocatable :: offloading_pes(:) + integer, allocatable :: model_pes(:) + integer, allocatable :: all_current_pes(:) + logical :: is_model_pe + + real(kind=r4_kind), allocatable :: var_r4_data(:,:) + type(domain2D) :: domain_out + type(domain2D) :: domain_in + integer :: isc, iec, jsc, jec + character(len=255) :: varname_tmp(1) + + offloading_pes = fileobj%offloading_obj_in%offloading_pes + model_pes = fileobj%offloading_obj_in%model_pes + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + + allocate(all_current_pes(mpp_npes())) + call mpp_get_current_pelist(all_current_pes) + + !Allocate space to store the data! + if (.not. is_model_pe) then + domain_out = this%domain_out + call mpp_get_compute_domain(domain_out, isc, iec, jsc, jec) + allocate(var_r4_data(isc:iec, jsc:jec)) + call mpp_define_null_domain(domain_in) + else + domain_in = fileobj%offloading_obj_in%domain_in + call mpp_define_null_domain(domain_out) + endif + + call mpp_broadcast_domain(domain_out) + call mpp_broadcast_domain(domain_in) + + ! redistribute data from model domain to offload domain and then free memory for future calls + call mpp_redistribute( domain_in, vardata, domain_out, var_r4_data) + call mpp_redistribute( domain_in, vardata, domain_out, var_r4_data, free=.true.) + + ! broadcast the variable name + if(mpp_pe() .eq. model_pes(1)) then + varname_tmp(1) = trim(varname) + endif + call mpp_broadcast(varname_tmp, 255, model_pes(1)) + + if (.not. is_model_pe) then + select type(wut=>this%fileobj) + type is(FmsNetcdfDomainFile_t) + call write_data(wut, varname_tmp(1), var_r4_data) + end select + endif + call mpp_set_current_pelist(all_current_pes) + end subroutine write_data_offload_2d + + !> Close offloaded netcdf file + subroutine close_file_offload(fileobj) + class(FmsNetcdfFile_t), intent(inout) :: fileobj !> fms2_io file object to close + + integer :: id + type(offloading_obj_out), pointer :: this + logical :: is_model_pe + + id = fileobj%offloading_obj_in%id + this => offloading_objs(id) + is_model_pe = fileobj%offloading_obj_in%is_model_pe + + if (.not. is_model_pe) call close_file(this%fileobj) + end subroutine close_file_offload + + !> Initialize an offloading object on offload PEs + integer function init_offloading_object(filename, nx, ny, ntile) + character(len=*), intent(in) :: filename !< filename to open + integer, intent(in) :: nx !< x size of the global domain + integer, intent(in) :: ny !< y size of the global domain + integer, intent(in) :: ntile !< number of tiles, only supports 1 for lat-lon or 6 for cubed-sphere + + type(offloading_obj_out), pointer :: this + integer, allocatable :: curr_pelist(:) + + current_files_init = current_files_init + 1 + if (current_files_init .gt. max_files) & + call mpp_error(FATAL, "The number of files is too large") + + ! An array of offloading objects is stored in this module, the "id" is the index of the object in the array + this => offloading_objs(current_files_init) + this%id = current_files_init + this%filename = trim(filename) + + ! does npes return current pelist or total?? + allocate(curr_pelist(mpp_npes())) + call mpp_get_current_pelist(curr_pelist) + + select case (ntile) + case (1) + this%domain_out = create_lat_lon_domain(nx, ny) + case (6) + this%domain_out = create_cubic_domain(nx, ny, ntile, (/1,1/), offload_pes=curr_pelist) + case default + call mpp_error(FATAL, "Unsupported number of tiles for offloading: " // trim(adjustl(string(ntile)))) + end select + + allocate(FmsNetcdfDomainFile_t :: this%fileobj) + select type (fileobj => this%fileobj) + type is (FmsNetcdfDomainFile_t) + if ( .not. open_file(fileobj, trim(this%filename), "overwrite", this%domain_out)) & + call mpp_error(FATAL, "Error opening file") + end select + + init_offloading_object = current_files_init + end function + + !! TODO move this somewhere else + function create_lat_lon_domain(nx_in, ny_in, halox, haloy ) & + result(domain_out) + integer, intent(in) :: nx_in !< number of lat-lon grid points in x direction + integer, intent(in) :: ny_in !< number of lat-lon grid points in y direction + integer, intent(in), optional :: halox !< number of halo points in x direction + integer, intent(in), optional :: haloy !< number of halo points in y direction + type(domain2d) :: domain_out + integer :: layout(2) + + call mpp_define_layout( (/1,nx_in,1,ny_in/), mpp_npes(), layout ) + call mpp_define_domains( (/1,nx_in,1,ny_in/), layout, domain_out, xhalo=halox, yhalo=haloy) + call mpp_define_io_domain(domain_out, (/1,1/)) + end function create_lat_lon_domain + + !! TODO move this somewhere else + function create_cubic_domain(nx_in, ny_in, ntiles, io_layout, nhalos, offload_pes, layout) & + result(domain_out) + integer, intent(in) :: nx_in !< number of grid points in x direction per tile + integer, intent(in) :: ny_in !< number of grid points in y direction per tile + integer, intent(in) :: ntiles !< number of tiles, must be 6 for cubed-sphere + integer, intent(in) :: io_layout(2) !< layout for I/O operations + integer, intent(in), optional :: nhalos !< number of halo points + integer, intent(in), optional :: offload_pes(:) !< list of PEs used for offloading write operations + integer, optional :: layout(2) !< layout to be used for each tile) + + type(domain2d) :: domain_out + + integer :: npes + integer :: npes_per_tile + integer :: layout_tmp(2) + integer, allocatable :: global_indices(:,:) + integer, allocatable :: layout2D(:,:) + integer, allocatable :: pe_start(:) + integer, allocatable :: pe_end(:) + integer :: n + + npes = mpp_npes() + if( mod(npes, ntiles) .NE. 0 ) call mpp_error(FATAL, & + "create_cubic_domain: npes is not divisible by ntiles") + + npes_per_tile = npes/ntiles + if( .not. present(layout)) then + call mpp_define_layout ((/1,nx_in,1,ny_in/), npes_per_tile, layout_tmp ) + else + layout_tmp = layout + endif + + allocate(global_indices(4, ntiles)) + allocate(layout2D(2, ntiles)) + allocate(pe_start(ntiles), pe_end(ntiles)) + + do n = 1, ntiles + global_indices(:,n) = (/1,nx_in,1,ny_in/) + layout2D(:,n) = layout_tmp + if( present(offload_pes)) then + pe_start(n) = offload_pes((n-1)*npes_per_tile+1) + pe_end(n) = offload_pes((n)*npes_per_tile) + else + pe_start(n) = (n-1)*npes_per_tile + pe_end(n) = n*npes_per_tile-1 + endif + end do + + print *, "pe: ", mpp_pe(), "creating mosaic with pe_start", pe_start, "pe_end", pe_end + + call define_cubic_mosaic(domain_out, (/nx_in,nx_in,nx_in,nx_in,nx_in,nx_in/), & + (/ny_in,ny_in,ny_in,ny_in,ny_in,ny_in/), & + global_indices, layout2D, pe_start, pe_end, io_layout, nhalos ) + end function create_cubic_domain + + !> @brief Initialize a cubed-sphere atomsphere domain. + !! TODO move this somehere else + subroutine define_cubic_mosaic(domain, ni, nj, global_indices, layout, pe_start, pe_end, & + io_layout, nhalos) + + integer, dimension(:), intent(in) :: ni !< number of grid points in i direction per tile + integer, dimension(:), intent(in) :: nj !< number of grid points in j direction per tile + integer, dimension(:,:), intent(in) :: global_indices !< global indices for each tile + integer, dimension(:,:), intent(in) :: layout !< array of layouts for each tile + integer, dimension(:), intent(in) :: pe_start !< starting PE for each tile + integer, dimension(:), intent(in) :: pe_end !< ending PE for each tile + integer, dimension(2), intent(in) :: io_layout !< layout for I/O operations + type(domain2d), intent(inout) :: domain !< A cubed-sphere domain. + integer, optional, intent(in) :: nhalos !< number of halo points + + integer, dimension(12) :: tile1 + integer, dimension(12) :: tile2 + integer, dimension(12) :: istart1 + integer, dimension(12) :: iend1 + integer, dimension(12) :: jstart1 + integer, dimension(12) :: jend1 + integer, dimension(12) :: istart2 + integer, dimension(12) :: iend2 + integer, dimension(12) :: jstart2 + integer, dimension(12) :: jend2 + integer :: ntiles + integer :: num_contact + integer, dimension(2) :: msize + integer :: whalo + integer :: ehalo + integer :: shalo + integer :: nhalo + + ntiles = 6 + num_contact = 12 + + whalo = 2 + if (present(nhalos)) whalo = nhalos + ehalo = whalo + shalo = whalo + nhalo = whalo + + if (size(pe_start) .ne. 6 .or. size(pe_end) .ne. 6 ) then + call mpp_error(FATAL, "size of pe_start and pe_end should be 6.") + endif + if (size(global_indices,1) .ne. 4) then + call mpp_error(FATAL, "size of first dimension of global_indices should be 4.") + endif + if (size(global_indices,2) .ne. 6) then + call mpp_error(FATAL, "size of second dimension of global_indices should be 6.") + endif + if (size(layout,1) .ne. 2) then + call mpp_error(FATAL, "size of first dimension of layout should be 2.") + endif + if (size(layout,2) .ne. 6) then + call mpp_error(FATAL, "size of second dimension of layout should be 6.") + endif + if (size(ni) .ne. 6 .or. size(nj) .ne. 6) then + call mpp_error(FATAL, "size of ni and nj should be 6.") + endif + + !Contact line 1, between tile 1 (EAST) and tile 2 (WEST) + tile1(1) = 1 + tile2(1) = 2 + istart1(1) = ni(1) + iend1(1) = ni(1) + jstart1(1) = 1 + jend1(1) = nj(1) + istart2(1) = 1 + iend2(1) = 1 + jstart2(1) = 1 + jend2(1) = nj(2) + + !Contact line 2, between tile 1 (NORTH) and tile 3 (WEST) + tile1(2) = 1 + tile2(2) = 3 + istart1(2) = 1 + iend1(2) = ni(1) + jstart1(2) = nj(1) + jend1(2) = nj(1) + istart2(2) = 1 + iend2(2) = 1 + jstart2(2) = nj(3) + jend2(2) = 1 + + !Contact line 3, between tile 1 (WEST) and tile 5 (NORTH) + tile1(3) = 1 + tile2(3) = 5 + istart1(3) = 1 + iend1(3) = 1 + jstart1(3) = 1 + jend1(3) = nj(1) + istart2(3) = ni(5) + iend2(3) = 1 + jstart2(3) = nj(5) + jend2(3) = nj(5) + + !Contact line 4, between tile 1 (SOUTH) and tile 6 (NORTH) + tile1(4) = 1 + tile2(4) = 6 + istart1(4) = 1 + iend1(4) = ni(1) + jstart1(4) = 1 + jend1(4) = 1 + istart2(4) = 1 + iend2(4) = ni(6) + jstart2(4) = nj(6) + jend2(4) = nj(6) + + !Contact line 5, between tile 2 (NORTH) and tile 3 (SOUTH) + tile1(5) = 2 + tile2(5) = 3 + istart1(5) = 1 + iend1(5) = ni(2) + jstart1(5) = nj(2) + jend1(5) = nj(2) + istart2(5) = 1 + iend2(5) = ni(3) + jstart2(5) = 1 + jend2(5) = 1 + + !Contact line 6, between tile 2 (EAST) and tile 4 (SOUTH) + tile1(6) = 2 + tile2(6) = 4 + istart1(6) = ni(2) + iend1(6) = ni(2) + jstart1(6) = 1 + jend1(6) = nj(2) + istart2(6) = ni(4) + iend2(6) = 1 + jstart2(6) = 1 + jend2(6) = 1 + + !Contact line 7, between tile 2 (SOUTH) and tile 6 (EAST) + tile1(7) = 2 + tile2(7) = 6 + istart1(7) = 1 + iend1(7) = ni(2) + jstart1(7) = 1 + jend1(7) = 1 + istart2(7) = ni(6) + iend2(7) = ni(6) + jstart2(7) = nj(6) + jend2(7) = 1 + + !Contact line 8, between tile 3 (EAST) and tile 4 (WEST) + tile1(8) = 3 + tile2(8) = 4 + istart1(8) = ni(3) + iend1(8) = ni(3) + jstart1(8) = 1 + jend1(8) = nj(3) + istart2(8) = 1 + iend2(8) = 1 + jstart2(8) = 1 + jend2(8) = nj(4) + + !Contact line 9, between tile 3 (NORTH) and tile 5 (WEST) + tile1(9) = 3 + tile2(9) = 5 + istart1(9) = 1 + iend1(9) = ni(3) + jstart1(9) = nj(3) + jend1(9) = nj(3) + istart2(9) = 1 + iend2(9) = 1 + jstart2(9) = nj(5) + jend2(9) = 1 + + !Contact line 10, between tile 4 (NORTH) and tile 5 (SOUTH) + tile1(10) = 4 + tile2(10) = 5 + istart1(10) = 1 + iend1(10) = ni(4) + jstart1(10) = nj(4) + jend1(10) = nj(4) + istart2(10) = 1 + iend2(10) = ni(5) + jstart2(10) = 1 + jend2(10) = 1 + + !Contact line 11, between tile 4 (EAST) and tile 6 (SOUTH) + tile1(11) = 4 + tile2(11) = 6 + istart1(11) = ni(4) + iend1(11) = ni(4) + jstart1(11) = 1 + jend1(11) = nj(4) + istart2(11) = ni(6) + iend2(11) = 1 + jstart2(11) = 1 + jend2(11) = 1 + + !Contact line 12, between tile 5 (EAST) and tile 6 (WEST) + tile1(12) = 5 + tile2(12) = 6 + istart1(12) = ni(5) + iend1(12) = ni(5) + jstart1(12) = 1 + jend1(12) = nj(5) + istart2(12) = 1 + iend2(12) = 1 + jstart2(12) = 1 + jend2(12) = nj(6) + msize(1) = maxval(ni(:)/layout(1,:)) + whalo + ehalo + 1 + msize(2) = maxval(nj(:)/layout(2,:)) + shalo + nhalo + 1 + call mpp_define_mosaic(global_indices, layout, domain, ntiles, num_contact, tile1, & + tile2, istart1, iend1, jstart1, jend1, istart2, iend2, & + jstart2, jend2, pe_start, pe_end, symmetry = .true., & + whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, & + name=trim("Cubed-sphere"), memory_size=msize) + call mpp_define_io_domain(domain, io_layout) + end subroutine define_cubic_mosaic +end module offloading_io_mod diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 9203360e5..754c5c662 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -26,7 +26,7 @@ ACLOCAL_AMFLAGS = -I m4 SUBDIRS = astronomy coupler diag_manager data_override exchange monin_obukhov drifters \ mosaic2 interpolator fms mpp time_interp time_manager horiz_interp topography \ field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres tracer_manager \ -random_numbers diag_integral column_diagnostics tridiagonal block_control +random_numbers diag_integral column_diagnostics tridiagonal offloading block_control # testing utility scripts to distribute EXTRA_DIST = test-lib.sh.in intel_coverage.sh.in tap-driver.sh diff --git a/test_fms/offloading/Makefile.am b/test_fms/offloading/Makefile.am new file mode 100644 index 000000000..92cac6edd --- /dev/null +++ b/test_fms/offloading/Makefile.am @@ -0,0 +1,50 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the test_fms/data_override directory of the FMS +# package. + +# uramirez + +# Find the needed mod and .inc files. +AM_CPPFLAGS = -I${top_srcdir}/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = ${top_builddir}/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_io_offloading test_metadata_transfer + +# This is the source code for the test. +test_io_offloading_SOURCES = test_io_offloading.F90 +test_metadata_transfer_SOURCES= test_metadata_transfer.F90 + +# Run the test program. +TESTS = test_io_offloading.sh + +# Define test file extensions and log driver +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(abs_top_srcdir)/test_fms/tap-driver.sh + +# Include these files with the distribution. +EXTRA_DIST = test_io_offloading.sh + +# Clean up +CLEANFILES = input.nml *.out diff --git a/test_fms/offloading/test_io_offloading.F90 b/test_fms/offloading/test_io_offloading.F90 new file mode 100644 index 000000000..1f21689b7 --- /dev/null +++ b/test_fms/offloading/test_io_offloading.F90 @@ -0,0 +1,148 @@ +!*********************************************************************** +!* Apache License 2.0 +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* Licensed under the Apache License, Version 2.0 (the "License"); +!* you may not use this file except in compliance with the License. +!* You may obtain a copy of the License at +!* +!* http://www.apache.org/licenses/LICENSE-2.0 +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +!* PARTICULAR PURPOSE. See the License for the specific language +!* governing permissions and limitations under the License. +!*********************************************************************** +program test_io_offloading + use fms_mod, only: fms_init, fms_end, string, check_nml_error + use platform_mod + use mpp_mod + use mpp_domains_mod + use offloading_io_mod + use fms2_io_mod + + implicit none + + integer, parameter :: lat_lon = 1 !< Using a lat lon domain + integer, parameter :: cube_sphere = 2 !< Using a cube sphere domain + integer, allocatable :: model_pes(:) !< The model PEs + integer, allocatable :: offload_pes(:) !< The PEs for offloading + integer, allocatable :: og_pes(:) !< all of the PEs + logical :: is_root_pe !< The root PE from all of the PEs + logical :: is_model_pe !< .True. if current PE is a member of the model_pes + logical :: is_offload_pe !< .True. if current PE is a member of the offload_pes + type(domain2D) :: model_domain !< Domain for the model PEs + integer :: i !< For do loops + integer :: io !< Error code when reading namelist + integer :: ierr !< Error code for namelist + character(len=30) :: filename !< Filename for the test + type(FmsNetcdfDomainFile_t) :: fileobj !< Fileobj for the test + real(kind=r4_kind), allocatable :: var_r4(:,:) !< Variable data for the "model" + + !< Namelist variables + integer :: nx = 96 !< Number of points in the x direction (per tile) + integer :: ny = 96 !< Number of points in the y direction (per tile) + integer :: nxhalo = 2 !< Number of halo points in the x direction + integer :: nyhalo = 2 !< Number of halo points in the x direction + integer :: noffload_pes = 1 !< Number of PEs to use for offloading (need 1 per tile) + integer :: nmodel_pes = 6 !< Number of PEs to use for the model + integer :: io_layout(2) !< Io layout to use for the model domain + integer :: domain_type = lat_lon !< The type of domain to use [lat_lon or cube_sphere] + + namelist /test_io_offloading_nml/ nx, ny, nxhalo, nyhalo, noffload_pes, nmodel_pes, domain_type + + call fms_init + call offloading_io_init + + read(input_nml_file, nml=test_io_offloading_nml, iostat=io) + ierr = check_nml_error(io, 'test_io_offloading_nml') + + if (mpp_npes() .ne. nmodel_pes + noffload_pes) & + call mpp_error(FATAL, "The total number of PEs "//string(mpp_npes())//" is not equal to model_pes + noffload_pes") + + is_root_pe = mpp_pe() .eq. mpp_root_pe() + allocate(og_pes(mpp_npes())) + call mpp_get_current_pelist(og_pes) + + allocate(model_pes(nmodel_pes)) + model_pes(1) = 0 + do i = 2, nmodel_pes + model_pes(i) = model_pes(i-1) + 1 + enddo + if (is_root_pe) print *, "Model PEs:", model_pes + call mpp_declare_pelist(model_pes, "model_pes") + + allocate(offload_pes(noffload_pes)) + offload_pes(1) = model_pes(nmodel_pes) + 1 + do i = 2, noffload_pes + offload_pes(i) = offload_pes(i-1) + 1 + enddo + if (is_root_pe) print *, "Offload PEs:", offload_pes + call mpp_declare_pelist(offload_pes, "offload_pes") + + is_model_pe = .false. + is_offload_pe = .false. + if (any(model_pes .eq. mpp_pe())) is_model_pe = .true. + if (any(offload_pes .eq. mpp_pe())) is_offload_pe = .true. + + if (is_model_pe) then + call mpp_set_current_pelist( model_pes ) + ! Only the model pes are creating the domain and allocating the data + select case (domain_type) + case (lat_lon) + model_domain = create_lat_lon_domain(nx, ny, halox=nxhalo, haloy=nyhalo) + case (cube_sphere) + model_domain = create_cubic_domain(nx, ny, 6, io_layout, nhalos=nxhalo) + end select + + filename = "atmos.daily.nc" + var_r4 = create_dummy_data(model_domain) + endif + + call mpp_set_current_pelist(og_pes) !All of the PEs need to call the offloading stuff + call open_file_offload(fileobj, filename, & + model_domain, & + model_pes, offload_pes) + + call global_metadata_offload(fileobj, "Number of times Fortran made you cry", 20) + call global_metadata_offload(fileobj, "Number of lines of code", 19.54326541) + + call register_axis_offload(fileobj, "lon", "x") + call register_axis_offload(fileobj, "lat", "x") + + call register_field_offload(fileobj, "mullions", "double", (/"lon", "lat"/)) + call write_data_offload(fileobj, "mullions", var_r4) + call close_file_offload(fileobj) + call fms_end + + contains + + function create_dummy_data(domain) & + result(dummy_data) + + type(domain2D), intent(in) :: domain + real(kind=r4_kind), allocatable :: dummy_data(:,:) + + integer :: is !< Starting x index + integer :: ie !< Ending x index + integer :: js !< Starting y index + integer :: je !< Ending y index + + integer :: j, k + + !Allocate the data to the size of the data domain but only fill the compute domain with data + call mpp_get_data_domain(domain, is, ie, js, je) + allocate(dummy_data(is:ie, js:je)) + dummy_data = -999_r4_kind + + call mpp_get_compute_domain(domain, is, ie, js, je) + do j = is, ie + do k = js, je + dummy_data(j, k) = real(j, kind=r4_kind)* 100_r4_kind + & + real(k, kind=r4_kind) + enddo + enddo + end function +end program test_io_offloading diff --git a/test_fms/offloading/test_io_offloading.sh b/test_fms/offloading/test_io_offloading.sh new file mode 100755 index 000000000..e2a4a0ee2 --- /dev/null +++ b/test_fms/offloading/test_io_offloading.sh @@ -0,0 +1,41 @@ +#!/bin/sh +#*********************************************************************** +#* Apache License 2.0 +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* Licensed under the Apache License, Version 2.0 (the "License"); +#* you may not use this file except in compliance with the License. +#* You may obtain a copy of the License at +#* +#* http://www.apache.org/licenses/LICENSE-2.0 +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +#* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +#* PARTICULAR PURPOSE. See the License for the specific language +#* governing permissions and limitations under the License. +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/offloading directory. + +# Set common test settings. +. ../test-lib.sh + +cat > input.nml << _EOF +offloading_io_nml + max_offloaded_files = 10 +/ +_EOF + +# TODO fails with older gnus +#test_expect_success "test_io_offloading" ' +# mpirun -n 7 ./test_io_offloading +#' + +test_expect_success "test metadata transfer" ' + mpirun -n 4 ./test_metadata_transfer +' + +test_done diff --git a/test_fms/offloading/test_metadata_transfer.F90 b/test_fms/offloading/test_metadata_transfer.F90 new file mode 100644 index 000000000..989c9960e --- /dev/null +++ b/test_fms/offloading/test_metadata_transfer.F90 @@ -0,0 +1,218 @@ +!*********************************************************************** +!* Apache License 2.0 +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* Licensed under the Apache License, Version 2.0 (the "License"); +!* you may not use this file except in compliance with the License. +!* You may obtain a copy of the License at +!* +!* http://www.apache.org/licenses/LICENSE-2.0 +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +!* PARTICULAR PURPOSE. See the License for the specific language +!* governing permissions and limitations under the License. +!*********************************************************************** +program test_metadata_transfer + use fms_mod, only: fms_init, fms_end, string + use mpp_mod + use metadata_transfer_mod + use platform_mod + use, intrinsic :: iso_c_binding + + implicit none + + class(metadata_class), allocatable :: file_metadata(:) + + logical :: debug = .true. + + call fms_init() + + allocate(metadata_r8_type :: file_metadata(3)) + ! all PEs need to initialize the metadata object with a datatype + call file_metadata(1)%fms_metadata_transfer_init(real8_type) + call file_metadata(2)%fms_metadata_transfer_init(real8_type) + call file_metadata(3)%fms_metadata_transfer_init(real8_type) + ! set metadata only on root PE + if (mpp_pe() .eq. mpp_root_pe()) then + call file_metadata(1)%set_attribute_name("_FillValue"//c_null_char) + select type(obj => file_metadata(1)) + type is(metadata_r8_type) + call obj%set_attribute_value([666.0_r8_kind]) + end select + call file_metadata(2)%set_attribute_name("missing_value"//c_null_char) + select type(obj => file_metadata(2)) + type is(metadata_r8_type) + call obj%set_attribute_value([-100.0_r8_kind, 100.0_r8_kind]) + end select + call file_metadata(3)%set_attribute_name("a_third_name"//c_null_char) + select type(obj => file_metadata(3)) + type is(metadata_r8_type) + call obj%set_attribute_value([-200.0_r8_kind, -50.0_r8_kind, 0.0_r8_kind, 50.0_r8_kind, 200.0_r8_kind]) + end select + endif + ! Broadcast the metadata to all PEs + call fms_metadata_broadcast_all(file_metadata) + ! Check data on all PEs + select type(file_metadata) + type is(metadata_r8_type) + if(debug) call dump_metadata_r8(file_metadata) + call check_metadata_r8(file_metadata) + end select + call mpp_sync() + deallocate(file_metadata) !! fails here on every PE besides root + + !! test with real4_type metadata + allocate(metadata_r4_type :: file_metadata(1)) + call file_metadata(1)%fms_metadata_transfer_init(real4_type) + if(mpp_pe() .eq. mpp_root_pe()) then + call file_metadata(1)%set_attribute_name("Valuez_r4"//c_null_char) + select type(obj => file_metadata(1)) + type is(metadata_r4_type) + call obj%set_attribute_value([666.0_r4_kind, -100.0_r4_kind, 100.0_r4_kind, -200.0_r4_kind, & + -50.0_r4_kind, 0.0_r4_kind, 50.0_r4_kind, 200.0_r4_kind]) + end select + endif + call fms_metadata_broadcast_all(file_metadata) + select type(file_metadata) + type is(metadata_r4_type) + print *, "PE: ", mpp_pe(), " metadata name is ", trim(adjustl(file_metadata(1)%get_attribute_name())) + print *, "PE: ", mpp_pe(), " metadata value is ", file_metadata(1)%get_attribute_value() + call check_metadata_r4(file_metadata) + end select + deallocate(file_metadata) + + !! test with int4_type metadata + allocate(metadata_i4_type :: file_metadata(1)) + call file_metadata(1)%fms_metadata_transfer_init(int4_type) + if(mpp_pe() .eq. mpp_root_pe()) then + call file_metadata(1)%set_attribute_name("Valuez_int4"//c_null_char) + select type(obj => file_metadata(1)) + type is(metadata_i4_type) + call obj%set_attribute_value([666, -100, 100, -200, & + -50, 0, 50, 200]) + end select + endif + call fms_metadata_broadcast_all(file_metadata) + select type(file_metadata) + type is(metadata_i4_type) + print *, "PE: ", mpp_pe(), " metadata name is ", trim(adjustl(file_metadata(1)%get_attribute_name())) + print *, "PE: ", mpp_pe(), " metadata value is ", file_metadata(1)%get_attribute_value() + end select + deallocate(file_metadata) + + !! test with int8_type metadata + allocate(metadata_i8_type :: file_metadata(1)) + call file_metadata(1)%fms_metadata_transfer_init(int8_type) + if(mpp_pe() .eq. mpp_root_pe()) then + call file_metadata(1)%set_attribute_name("Valuez_int8"//c_null_char) + select type(obj => file_metadata(1)) + type is(metadata_i8_type) + call obj%set_attribute_value([666_i8_kind, -100_i8_kind, 100_i8_kind, -200_i8_kind, & + -50_i8_kind, 0_i8_kind, 50_i8_kind, 200_i8_kind]) + end select + endif + call fms_metadata_broadcast_all(file_metadata) + select type(file_metadata) + type is(metadata_i8_type) + print *, "PE: ", mpp_pe(), " metadata name is ", trim(adjustl(file_metadata(1)%get_attribute_name())) + print *, "PE: ", mpp_pe(), " metadata value is ", file_metadata(1)%get_attribute_value() + end select + deallocate(file_metadata) + + !! test with str_type metadata + allocate(metadata_str_type :: file_metadata(1)) + call file_metadata(1)%fms_metadata_transfer_init(int4_type) + if(mpp_pe() .eq. mpp_root_pe()) then + call file_metadata(1)%set_attribute_name("foo"//c_null_char) + select type(obj => file_metadata(1)) + type is(metadata_str_type) + call obj%set_attribute_value("bar") + end select + endif + call fms_metadata_broadcast_all(file_metadata) + select type(file_metadata) + type is(metadata_str_type) + print *, "PE: ", mpp_pe(), " metadata name is ", trim(adjustl(file_metadata(1)%get_attribute_name())) + print *, "PE: ", mpp_pe(), " metadata value is ", file_metadata(1)%get_attribute_value() + if(trim(file_metadata(1)%get_attribute_name()) .ne. "foo"//c_null_char .or. & + trim(file_metadata(1)%get_attribute_value()) .ne. "bar") then + call mpp_error(FATAL, "incorrect metadata name") + endif + end select + deallocate(file_metadata) + + call fms_end() + + contains + + subroutine dump_metadata_r8(this) + type(metadata_r8_type), intent(inout) :: this(:) + real(r8_kind), allocatable :: arr(:) + + integer :: i + do i = 1, size(this) + arr = this(i)%get_attribute_value() + print *, "pe: ", mpp_pe(), "i: ", i, " attribute_name is ", trim(adjustl(this(i)%get_attribute_name())) + print *, "pe: ", mpp_pe(), "i: ", i, " attribute_value is ", arr + enddo + end subroutine + + subroutine check_metadata_r8(this) + type(metadata_r8_type), intent(inout) :: this(:) + real(r8_kind), allocatable :: arr(:) + character(len=32) :: attr_names(3) + real(r8_kind) :: attr_vals(8) + integer :: i, j, last_j =1 + + attr_names(1) = "_FillValue"//c_null_char + attr_names(2) = "missing_value"//c_null_char + attr_names(3) = "a_third_name"//c_null_char + attr_vals = (/ 666.0_r8_kind, -100.0_r8_kind, 100.0_r8_kind, -200.0_r8_kind, & + -50.0_r8_kind, 0.0_r8_kind, 50.0_r8_kind, 200.0_r8_kind /) + + do i = 1, size(this) + arr = this(i)%get_attribute_value() + if (trim(this(i)%get_attribute_name()) .ne. attr_names(i)) then + call mpp_error(FATAL, "incorrect metadata name") + endif + + do j=1, size(arr) + if (arr(j) .ne. attr_vals(last_j)) then + print *, "got ", arr(j), " expected ", attr_vals(last_j) + call mpp_error(FATAL, "incorrect metadata value") + endif + last_j = last_j + 1 + enddo + + enddo + end subroutine + + subroutine check_metadata_r4(this) + type(metadata_r4_type), intent(inout) :: this(:) + real(r4_kind), allocatable :: arr(:) + character(len=32) :: attr_name + real(r4_kind) :: attr_vals(8) + integer :: j, last_j =1 + + attr_name = "Valuez_r4"//c_null_char + attr_vals = (/ 666.0_r4_kind, -100.0_r4_kind, 100.0_r4_kind, -200.0_r4_kind, & + -50.0_r4_kind, 0.0_r4_kind, 50.0_r4_kind, 200.0_r4_kind /) + + arr = this(1)%get_attribute_value() + if (trim(this(1)%get_attribute_name()) .ne. attr_name) then + print *, "got ", trim(this(1)%get_attribute_name()), " expected ", trim(attr_name) + call mpp_error(FATAL, "incorrect metadata name") + endif + + do j=1, size(arr) + if (arr(j) .ne. attr_vals(j)) then + print *, "got ", arr(j), " expected ", attr_vals(last_j) + call mpp_error(FATAL, "incorrect metadata value") + endif + enddo + end subroutine + +end program