From 49eda2e92715c0ad18df23645effc81980cbcfa3 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Tue, 9 Aug 2022 14:56:39 -0400 Subject: [PATCH 01/11] Creates the fmsDiagField_type Keeps some of the routines in the fms_diag_object_mod --- CMakeLists.txt | 1 + diag_manager/Makefile.am | 8 +- diag_manager/diag_manager.F90 | 2 +- diag_manager/fms_diag_field_object.F90 | 1176 ++++++++++++++++++++ diag_manager/fms_diag_object.F90 | 979 ++-------------- diag_manager/fms_diag_object_container.F90 | 16 +- 6 files changed, 1259 insertions(+), 923 deletions(-) create mode 100644 diag_manager/fms_diag_field_object.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 63a3ed493c..a204887fca 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -127,6 +127,7 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_object.F90 diag_manager/fms_diag_yaml.F90 diag_manager/fms_diag_file_object.F90 + diag_manager/fms_diag_field_object.F90 diag_manager/fms_diag_axis_object.F90 diag_manager/fms_diag_dlinked_list.F90 diag_manager/fms_diag_object_container.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 8531d05024..f8020cd393 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -39,6 +39,7 @@ libdiag_manager_la_SOURCES = \ diag_table.F90 \ diag_util.F90 \ fms_diag_file_object.F90 \ + fms_diag_field_object.F90 \ fms_diag_yaml.F90 \ fms_diag_object.F90 \ fms_diag_axis_object.F90 \ @@ -52,9 +53,11 @@ diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) -fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ +fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) -fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) +fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ + diag_util_mod.$(FC_MODEXT) +fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ @@ -73,6 +76,7 @@ MODFILES = \ diag_table_mod.$(FC_MODEXT) \ fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_file_object_mod.$(FC_MODEXT) \ + fms_diag_field_object_mod.$(FC_MODEXT) \ fms_diag_object_mod.$(FC_MODEXT) \ fms_diag_axis_object_mod.$(FC_MODEXT) \ fms_diag_dlinked_list_mod.$(FC_MODEXT) \ diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 8b1c2d6f7d..a8ed7fc545 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -236,7 +236,7 @@ MODULE diag_manager_mod USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end - USE fms_diag_object_mod, ONLY: fmsDiagObject_type, fms_diag_object_init, fms_register_diag_field_array, & + USE fms_diag_field_object_mod, ONLY: fmsDiagField_type, fms_diag_object_init, fms_register_diag_field_array, & & fms_register_diag_field_scalar, fms_diag_object_end, fms_register_static_field, fms_diag_field_add_attribute, & & fms_get_diag_field_id USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 new file mode 100644 index 0000000000..3d078e1254 --- /dev/null +++ b/diag_manager/fms_diag_field_object.F90 @@ -0,0 +1,1176 @@ +module fms_diag_field_object_mod +!> \author Tom Robinson +!> \email thomas.robinson@noaa.gov +!! \brief Contains routines for the diag_objects +!! +!! \description The diag_manager passes an object back and forth between the diag routines and the users. +!! The procedures of this object and the types are all in this module. The fms_dag_object is a type +!! that contains all of the information of the variable. It is extended by a type that holds the +!! appropriate buffer for the data for manipulation. +use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string +use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN +use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type +use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & + &DIAG_FIELD_NOT_FOUND + +use diag_axis_mod, only: diag_axis_type +use mpp_mod, only: fatal, note, warning, mpp_error +#ifdef use_yaml +use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, & + & find_diag_field, get_num_unique_fields +#endif +use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type +use time_manager_mod, ONLY: time_type +!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& +!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & +!!! & get_ticks_per_second + +use platform_mod +use iso_c_binding + +implicit none + +!> \brief Object that holds all variable information +type fmsDiagField_type +#ifdef use_yaml + type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable + integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable + !! belongs to +#endif + integer, allocatable, private :: diag_id !< unique id for varable + type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable + integer, private :: num_attributes !< Number of attributes currently added + logical, allocatable, private :: static !< true if this is a static var + logical, allocatable, private :: registered !< true when registered + logical, allocatable, private :: mask_variant !< If there is a mask variant + logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field + logical, allocatable, private :: local !< If the output is local + TYPE(time_type), private :: init_time !< The initial time + integer, allocatable, private :: vartype !< the type of varaible + character(len=:), allocatable, private :: varname !< the name of the variable + character(len=:), allocatable, private :: longname !< longname of the variable + character(len=:), allocatable, private :: standname !< standard name of the variable + character(len=:), allocatable, private :: units !< the units + character(len=:), allocatable, private :: modname !< the module + character(len=:), allocatable, private :: realm !< String to set as the value + !! to the modeling_realm attribute + character(len=:), allocatable, private :: interp_method !< The interp method to be used + !! when regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + integer, allocatable, dimension(:), private :: frequency !< specifies the frequency + integer, allocatable, dimension(:), private :: output_units + integer, allocatable, private :: t + integer, allocatable, private :: tile_count !< The number of tiles + integer, pointer, dimension(:), private :: axis_ids !< variable axis IDs + class(diagDomain_t), pointer, private :: domain !< Domain + INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", + !! "TWO_D_DOMAIN", or "UG_DOMAIN") + integer, allocatable, private :: area, volume !< The Area and Volume + class(*), allocatable, private :: missing_value !< The missing fill value + class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data + class(*), allocatable :: vardata0 !< Scalar data buffer + class(*), allocatable, dimension(:) :: vardata1 !< 1D data buffer + class(*), allocatable, dimension(:,:) :: vardata2 !< 2D data buffer + class(*), allocatable, dimension(:,:,:) :: vardata3 !< 3D data buffer + class(*), allocatable, dimension(:,:,:,:) :: vardata4 !< 4D data buffer + class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 !< 5D data buffer + contains +! procedure :: send_data => fms_send_data !!TODO + procedure :: init_ob => diag_obj_init + procedure :: get_id => fms_diag_get_id + procedure :: id => fms_diag_get_id + procedure :: copy => copy_diag_obj + procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. + procedure :: setID => set_diag_id + procedure :: set_type => set_vartype + procedure :: vartype_inq => what_is_vartype +! Check functions + procedure :: is_static => diag_obj_is_static + procedure :: is_registered => diag_ob_registered + procedure :: is_registeredB => diag_obj_is_registered + procedure :: is_mask_variant => get_mask_variant + procedure :: is_local => get_local +! Is variable allocated check functions +!TODO procedure :: has_diag_field + procedure :: has_diag_id + procedure :: has_attributes + procedure :: has_static + procedure :: has_registered + procedure :: has_mask_variant + procedure :: has_local +!TODO procedure :: has_init_time + procedure :: has_vartype + procedure :: has_varname + procedure :: has_longname + procedure :: has_standname + procedure :: has_units + procedure :: has_modname + procedure :: has_realm + procedure :: has_interp_method + procedure :: has_frequency + procedure :: has_output_units + procedure :: has_t + procedure :: has_tile_count + procedure :: has_area + procedure :: has_volume + procedure :: has_missing_value + procedure :: has_data_RANGE +! Get functions + procedure :: get_diag_id => fms_diag_get_id + procedure :: get_attributes + procedure :: get_static + procedure :: get_registered + procedure :: get_mask_variant + procedure :: get_local + procedure :: get_vartype + procedure :: get_varname + procedure :: get_longname + procedure :: get_standname + procedure :: get_units + procedure :: get_modname + procedure :: get_realm + procedure :: get_interp_method + procedure :: get_frequency + procedure :: get_output_units + procedure :: get_t + procedure :: get_tile_count + procedure :: get_area + procedure :: get_volume + procedure :: get_missing_value + procedure :: get_data_RANGE +!TODO procedure :: get_init_time +!TODO procedure :: get_axis +end type fmsDiagField_type +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +type(fmsDiagField_type) :: null_ob + +integer,private :: MAX_LEN_VARNAME +integer,private :: MAX_LEN_META +logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized + +TYPE(fmsDiagField_type), private, ALLOCATABLE, target :: diag_objs(:) !< Array of diag objects + !! one for each registered variable +integer, private :: registered_variables !< Number of registered variables + +!type(fmsDiagField_type) :: diag_object_placeholder (10) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +public :: fmsDiagField_type +public :: null_ob +public :: copy_diag_obj, fms_diag_get_id +public :: fms_diag_object_init +public :: fms_diag_object_end +public :: fms_register_diag_field_array +public :: fms_register_diag_field_scalar +public :: fms_register_static_field +public :: fms_diag_field_add_attribute +public :: get_diag_obj_from_id +public :: fms_get_diag_field_id +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> @brief Initiliazes the array of diag_objs based on the number of unique diag_fields in the diag_table +subroutine fms_diag_object_init (mlv,mlm) + integer, intent(in) :: mlv !< The maximum length of the varname + integer, intent(in) :: mlm !< The maximum length of the metadata + + if (module_is_initialized) return + +!> Get info from the namelist + MAX_LEN_VARNAME = mlv + MAX_LEN_META = mlm +!> Initialize the null_d variables + null_ob%diag_id = DIAG_NULL +#ifdef use_yaml + allocate(diag_objs(get_num_unique_fields())) + registered_variables = 0 +#endif + module_is_initialized = .true. +end subroutine fms_diag_object_init + +!> @brief Deallocates the array of diag_objs +subroutine fms_diag_object_end () + if (.not. module_is_initialized) return + + if (allocated(diag_objs)) deallocate(diag_objs) + + module_is_initialized = .false. +end subroutine fms_diag_object_end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \Description Sets the diag_id to the not registered value. +subroutine diag_obj_init(ob) + class (fmsDiagField_type) , intent(inout) :: ob + select type (ob) + class is (fmsDiagField_type) + ob%diag_id = diag_not_registered !null_ob%diag_id + ob%registered = .false. + end select +end subroutine diag_obj_init +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \Description Fills in and allocates (when necessary) the values in the diagnostic object +subroutine fms_register_diag_field_obj & + !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata) + (dobj, modname, varname, diag_field_indices, axes, init_time, & + longname, units, missing_value, varRange, mask_variant, standname, & + do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + + class(fmsDiagField_type), INTENT(inout) :: dobj !< Diaj_obj to fill + CHARACTER(len=*), INTENT(in) :: modname !< The module name + CHARACTER(len=*), INTENT(in) :: varname !< The variable name + integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field + !! in the yaml object + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time + INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies + CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name + class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute + class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles + INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id of the cell area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the + !! modeling_realm attribute + + integer :: i !< For do loops + integer :: j !< dobj%file_ids(i) (for less typing :) + +#ifdef use_yaml +!> Fill in information from the register call + dobj%varname = trim(varname) + dobj%modname = trim(modname) + +!> Fill in diag_field and find the ids of the files that this variable is in + dobj%diag_field = get_diag_fields_entries(diag_field_indices) + dobj%file_ids = get_diag_files_id(diag_field_indices) + + if (present(axes)) then + dobj%axis_ids => axes + call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname) + do i = 1, size(dobj%file_ids) + j = dobj%file_ids(i) + call FMS_diag_files(j)%set_file_domain(dobj%domain, dobj%type_of_domain) + call FMS_diag_files(j)%add_axes(axes) + if (present(init_time)) call FMS_diag_files(j)%add_start_time(init_time) + enddo + !> TO DO: + !! Mark the field as registered in the diag_files + else + !> The variable is a scalar + dobj%type_of_domain = NO_DOMAIN + dobj%domain => null() + endif + +!> get the optional arguments if included and the diagnostic is in the diag table + if (present(longname)) dobj%longname = trim(longname) + if (present(standname)) dobj%standname = trim(standname) + if (present(units)) dobj%units = trim(units) + if (present(realm)) dobj%realm = trim(realm) + if (present(interp_method)) dobj%interp_method = trim(interp_method) + if (present(tile_count)) then + allocate(dobj%tile_count) + dobj%tile_count = tile_count + endif + + if (present(missing_value)) then + select type (missing_value) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: dobj%missing_value) + dobj%missing_value = missing_value + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: dobj%missing_value) + dobj%missing_value = missing_value + type is (real(kind=r4_kind)) + allocate(integer(kind=r4_kind) :: dobj%missing_value) + dobj%missing_value = missing_value + type is (real(kind=r8_kind)) + allocate(integer(kind=r8_kind) :: dobj%missing_value) + dobj%missing_value = missing_value + class default + call mpp_error("fms_register_diag_field_obj", & + "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",& + FATAL) + end select + else + allocate(real :: dobj%missing_value) + select type (miss => dobj%missing_value) + type is (real) + miss = real(CMOR_MISSING_VALUE) + end select + endif + + if (present(varRANGE)) then + select type (varRANGE) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: dobj%data_RANGE(2)) + dobj%data_RANGE = varRANGE + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: dobj%data_RANGE(2)) + dobj%data_RANGE = varRANGE + type is (real(kind=r4_kind)) + allocate(integer(kind=r4_kind) :: dobj%data_RANGE(2)) + dobj%data_RANGE = varRANGE + type is (real(kind=r8_kind)) + allocate(integer(kind=r8_kind) :: dobj%data_RANGE(2)) + dobj%data_RANGE = varRANGE + class default + call mpp_error("fms_register_diag_field_obj", & + "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",& + FATAL) + end select + else + allocate(real :: dobj%data_RANGE(2)) + select type (varRANGE => dobj%data_RANGE) + type is (real) + varRANGE = real(CMOR_MISSING_VALUE) + end select + endif + + if (present(area)) then + if (area < 0) call mpp_error("fms_register_diag_field_obj", & + "The area id passed with field_name"//trim(varname)//" has not been registered."& + "Check that there is a register_diag_field call for the AREA measure and that is in the"& + "diag_table.yaml", FATAL) + allocate(dobj%area) + dobj%area = area + endif + + if (present(volume)) then + if (volume < 0) call mpp_error("fms_register_diag_field_obj", & + "The volume id passed with field_name"//trim(varname)//" has not been registered."& + "Check that there is a register_diag_field call for the VOLUME measure and that is in the"& + "diag_table.yaml", FATAL) + allocate(dobj%volume) + dobj%volume = volume + endif + + if (present(mask_variant)) then + allocate(dobj%mask_variant) + dobj%mask_variant = mask_variant + endif + + if (present(do_not_log)) then + allocate(dobj%do_not_log) + dobj%do_not_log = do_not_log + endif + + !< Allocate space for any additional variable attributes + !< These will be fill out when calling `diag_field_add_attribute` + allocate(dobj%attributes(max_field_attributes)) + dobj%num_attributes = 0 + dobj%registered = .true. +#endif +end subroutine fms_register_diag_field_obj +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \brief Sets the diag_id. This can only be done if a variable is unregistered +subroutine set_diag_id(objin , id) + class (fmsDiagField_type) , intent(inout):: objin + integer :: id + if (allocated(objin%registered)) then + if (objin%registered) then + call mpp_error("set_diag_id", "The variable"//objin%varname//" is already registered", FATAL) + endif + else + objin%diag_id = id + endif +end subroutine set_diag_id +!> \brief Find the type of the variable and store it in the object +subroutine set_vartype(objin , var) + class (fmsDiagField_type) , intent(inout):: objin + class(*) :: var + select type (var) + type is (real(kind=8)) + objin%vartype = r8 + type is (real(kind=4)) + objin%vartype = r4 + type is (integer(kind=8)) + objin%vartype = i8 + type is (integer(kind=4)) + objin%vartype = i4 + type is (character(*)) + objin%vartype = string + class default + objin%vartype = null_type_int + call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// & + " r8, r4, i8, i4, or string.", warning) + end select +end subroutine set_vartype +!> \brief Prints to the screen what type the diag variable is +subroutine what_is_vartype(objin) + class (fmsDiagField_type) , intent(inout):: objin + if (.not. allocated(objin%vartype)) then + call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning) + return + endif + select case (objin%vartype) + case (r8) + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " is REAL(kind=8)", NOTE) + case (r4) + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " is REAL(kind=4)", NOTE) + case (i8) + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " is INTEGER(kind=8)", NOTE) + case (i4) + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " is INTEGER(kind=4)", NOTE) + case (string) + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " is CHARACTER(*)", NOTE) + case (null_type_int) + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " was not set", WARNING) + case default + call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& + " is not supported by diag_manager", FATAL) + end select +end subroutine what_is_vartype +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!MZ Is this a TODO. Many problems: +!> \brief Registers the object +subroutine diag_ob_registered(objin , reg) + class (fmsDiagField_type) , intent(inout):: objin + logical , intent(in) :: reg !< If registering, this is true + objin%registered = reg +end subroutine diag_ob_registered +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \brief Copies the calling object into the object that is the argument of the subroutine +subroutine copy_diag_obj(objin , objout) + class (fmsDiagField_type) , intent(in) :: objin + class (fmsDiagField_type) , intent(inout) , allocatable :: objout !< The destination of the copy +select type (objout) + class is (fmsDiagField_type) + + if (allocated(objin%registered)) then + objout%registered = objin%registered + else + call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning) + endif + objout%diag_id = objin%diag_id + + if (allocated(objin%attributes)) objout%attributes = objin%attributes + objout%static = objin%static + if (allocated(objin%frequency)) objout%frequency = objin%frequency + if (allocated(objin%varname)) objout%varname = objin%varname +end select +end subroutine copy_diag_obj +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \brief Returns the ID integer for a variable +!! \return the diag ID +integer function fms_diag_get_id (dobj) result(diag_id) + class(fmsDiagField_type) , intent(inout) :: dobj +! character(*) , intent(in) :: varname +!> Check if the diag_object registration has been done + if (allocated(dobj%registered)) then + !> Return the diag_id if the variable has been registered + diag_id = dobj%diag_id + else +!> If the variable is not regitered, then return the unregistered value + diag_id = DIAG_NOT_REGISTERED + endif +end function fms_diag_get_id + +!> Function to return a character (string) representation of the most basic +!> object identity info. Intended for debugging and warning. The format produced is: +!> [dobj: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)]. +!> A questionmark "?" is set in place of the variable that is not yet allocated +!>TODO: Add diag_id ? +function fms_diag_obj_as_string_basic(dobj) result(rslt) + class(fmsDiagField_type), allocatable, intent(in) :: dobj + character(:), allocatable :: rslt + character (len=:), allocatable :: registered, vartype, varname, diag_id + if ( .not. allocated (dobj)) then + varname = "?" + vartype = "?" + registered = "?" + diag_id = "?" + rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]" + return + end if + +! if(allocated (dobj%registered)) then +! registered = logical_to_cs (dobj%registered) +! else +! registered = "?" +! end if + +! if(allocated (dobj%diag_id)) then +! diag_id = int_to_cs (dobj%diag_id) +! else +! diag_id = "?" +! end if + +! if(allocated (dobj%vartype)) then +! vartype = int_to_cs (dobj%vartype) +! else +! registered = "?" +! end if + + if(allocated (dobj%varname)) then + varname = dobj%varname + else + registered = "?" + end if + + rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]" + +end function fms_diag_obj_as_string_basic + + +function diag_obj_is_registered (obj) result (rslt) + class(fmsDiagField_type), intent(in) :: obj + logical :: rslt + rslt = obj%registered +end function diag_obj_is_registered + +function diag_obj_is_static (obj) result (rslt) + class(fmsDiagField_type), intent(in) :: obj + logical :: rslt + rslt = obj%static +end function diag_obj_is_static + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Get functions + +!> @brief Gets attributes +!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes +function get_attributes (obj) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: obj !< diag object + type(fmsDiagAttribute_type), pointer :: rslt(:) + + rslt => null() + if (obj%num_attributes > 0 ) rslt => obj%attributes +end function get_attributes +!> @brief Gets static +!! @return copy of variable static +pure function get_static (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + logical :: rslt + rslt = obj%static +end function get_static +!> @brief Gets regisetered +!! @return copy of registered +pure function get_registered (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + logical :: rslt + rslt = obj%registered +end function get_registered +!> @brief Gets mask variant +!! @return copy of mask variant +pure function get_mask_variant (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + logical :: rslt + rslt = obj%mask_variant +end function get_mask_variant +!> @brief Gets local +!! @return copy of local +pure function get_local (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + logical :: rslt + rslt = obj%local +end function get_local +!> @brief Gets initial time +!! @return copy of the initial time +!! TODO +!function get_init_time (obj) & +!result(rslt) +! class (fmsDiagField_type), intent(in) :: obj !< diag object +! TYPE(time_type) :: rslt +! +!end function get_init_time +!> @brief Gets vartype +!! @return copy of The integer related to the variable type +pure function get_vartype (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer :: rslt + rslt = obj%vartype +end function get_vartype +!> @brief Gets varname +!! @return copy of the variable name +pure function get_varname (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + rslt = obj%varname +end function get_varname +!> @brief Gets longname +!! @return copy of the variable long name or a single string if there is no long name +pure function get_longname (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%longname)) then + rslt = obj%longname + else + rslt = diag_null_string + endif +end function get_longname +!> @brief Gets standname +!! @return copy of the standard name or an empty string if standname is not allocated +pure function get_standname (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%standname)) then + rslt = obj%standname + else + rslt = diag_null_string + endif +end function get_standname +!> @brief Gets units +!! @return copy of the units or an empty string if not allocated +pure function get_units (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%units)) then + rslt = obj%units + else + rslt = diag_null_string + endif +end function get_units +!> @brief Gets modname +!! @return copy of the module name that the variable is in or an empty string if not allocated +pure function get_modname (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%modname)) then + rslt = obj%modname + else + rslt = diag_null_string + endif +end function get_modname +!> @brief Gets realm +!! @return copy of the variables modeling realm or an empty string if not allocated +pure function get_realm (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%realm)) then + rslt = obj%realm + else + rslt = diag_null_string + endif +end function get_realm +!> @brief Gets interp_method +!! @return copy of The interpolation method or an empty string if not allocated +pure function get_interp_method (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%interp_method)) then + rslt = obj%interp_method + else + rslt = diag_null_string + endif +end function get_interp_method +!> @brief Gets frequency +!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated +pure function get_frequency (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer, allocatable, dimension (:) :: rslt + if (allocated(obj%frequency)) then + allocate (rslt(size(obj%frequency))) + rslt = obj%frequency + else + allocate (rslt(1)) + rslt = DIAG_NULL + endif +end function get_frequency +!> @brief Gets output_units +!! @return copy of The units of the output or DIAG_NULL is output_units is not allocated +pure function get_output_units (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer,allocatable, dimension (:) :: rslt + if (allocated(obj%output_units)) then + allocate (rslt(size(obj%output_units))) + rslt = obj%output_units + else + allocate (rslt(1)) + rslt = DIAG_NULL + endif +end function get_output_units +!> @brief Gets t +!! @return copy of t +pure function get_t (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer :: rslt + if (allocated(obj%t)) then + rslt = obj%t + else + rslt = -999 + endif +end function get_t +!> @brief Gets tile_count +!! @return copy of the number of tiles or diag_null if tile_count is not allocated +pure function get_tile_count (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer :: rslt + if (allocated(obj%tile_count)) then + rslt = obj%tile_count + else + rslt = DIAG_NULL + endif +end function get_tile_count +!> @brief Gets area +!! @return copy of the area or diag_null if not allocated +pure function get_area (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer :: rslt + if (allocated(obj%area)) then + rslt = obj%area + else + rslt = diag_null + endif +end function get_area +!> @brief Gets volume +!! @return copy of the volume or diag_null if volume is not allocated +pure function get_volume (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + integer :: rslt + if (allocated(obj%volume)) then + rslt = obj%volume + else + rslt = diag_null + endif +end function get_volume +!> @brief Gets missing_value +!! @return copy of The missing value +function get_missing_value (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + class(*),allocatable :: rslt + if (allocated(obj%missing_value)) then + select type (miss => obj%missing_value) + type is (integer(kind=i4_kind)) + allocate (integer(kind=i4_kind) :: rslt) + rslt = miss + type is (integer(kind=i8_kind)) + allocate (integer(kind=i8_kind) :: rslt) + rslt = miss + type is (real(kind=r4_kind)) + allocate (integer(kind=i4_kind) :: rslt) + rslt = miss + type is (real(kind=r8_kind)) + allocate (integer(kind=i4_kind) :: rslt) + rslt = miss + class default + call mpp_error ("get_missing_value", & + "The missing value is not a r8, r4, i8, or i4",& + FATAL) + end select + else + call mpp_error ("get_missing_value", & + "The missing value is not allocated", FATAL) + endif +end function get_missing_value +!> @brief Gets data_range +!! @return copy of the data range +function get_data_RANGE (obj) & +result(rslt) + class (fmsDiagField_type), intent(in) :: obj !< diag object + class(*),allocatable :: rslt(:) + if (allocated(obj%data_RANGE)) then + select type (r => obj%data_RANGE) + type is (integer(kind=i4_kind)) + allocate (integer(kind=i4_kind) :: rslt(2)) + rslt = r + type is (integer(kind=i8_kind)) + allocate (integer(kind=i8_kind) :: rslt(2)) + rslt = r + type is (real(kind=r4_kind)) + allocate (integer(kind=i4_kind) :: rslt(2)) + rslt = r + type is (real(kind=r8_kind)) + allocate (integer(kind=i4_kind) :: rslt(2)) + rslt = r + class default + call mpp_error ("get_data_RANGE", & + "The data_RANGE value is not a r8, r4, i8, or i4",& + FATAL) + end select + else + call mpp_error ("get_data_RANGE", & + "The data_RANGE value is not allocated", FATAL) + endif +end function get_data_RANGE +!> @brief Gets axis +!! @return copy of axis information +!! TODO +!function get_axis (obj) & +!result(rslt) +! class (fmsDiagField_type), intent(in) :: obj !< diag object +! type (diag_axis_type), allocatable, dimension(:) :: rslt +! +!end function get_axis +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!! Allocation checks +!!> @brief Checks if obj%diag_field is allocated +!!! @return true if obj%diag_field is allocated +!logical function has_diag_field (obj) +! class (fmsDiagField_type), intent(in) :: obj !< diag object +! has_diag_field = allocated(obj%diag_field) +!end function has_diag_field +!> @brief Checks if obj%diag_id is allocated +!! @return true if obj%diag_id is allocated +pure logical function has_diag_id (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_diag_id = allocated(obj%diag_id) +end function has_diag_id +!> @brief Checks if obj%metadata is allocated +!! @return true if obj%metadata is allocated +pure logical function has_attributes (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_attributes = obj%num_attributes > 0 +end function has_attributes +!> @brief Checks if obj%static is allocated +!! @return true if obj%static is allocated +pure logical function has_static (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_static = allocated(obj%static) +end function has_static +!> @brief Checks if obj%registered is allocated +!! @return true if obj%registered is allocated +pure logical function has_registered (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_registered = allocated(obj%registered) +end function has_registered +!> @brief Checks if obj%mask_variant is allocated +!! @return true if obj%mask_variant is allocated +pure logical function has_mask_variant (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_mask_variant = allocated(obj%mask_variant) +end function has_mask_variant +!> @brief Checks if obj%local is allocated +!! @return true if obj%local is allocated +pure logical function has_local (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_local = allocated(obj%local) +end function has_local +!!> @brief Checks if obj%init_time is allocated +!!! @return true if obj%init_time is allocated +!logical function has_init_time (obj) +! class (fmsDiagField_type), intent(in) :: obj !< diag object +! has_init_time = allocated(obj%init_time) +!end function has_init_time +!> @brief Checks if obj%vartype is allocated +!! @return true if obj%vartype is allocated +pure logical function has_vartype (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_vartype = allocated(obj%vartype) +end function has_vartype +!> @brief Checks if obj%varname is allocated +!! @return true if obj%varname is allocated +pure logical function has_varname (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_varname = allocated(obj%varname) +end function has_varname +!> @brief Checks if obj%longname is allocated +!! @return true if obj%longname is allocated +pure logical function has_longname (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_longname = allocated(obj%longname) +end function has_longname +!> @brief Checks if obj%standname is allocated +!! @return true if obj%standname is allocated +pure logical function has_standname (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_standname = allocated(obj%standname) +end function has_standname +!> @brief Checks if obj%units is allocated +!! @return true if obj%units is allocated +pure logical function has_units (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_units = allocated(obj%units) +end function has_units +!> @brief Checks if obj%modname is allocated +!! @return true if obj%modname is allocated +pure logical function has_modname (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_modname = allocated(obj%modname) +end function has_modname +!> @brief Checks if obj%realm is allocated +!! @return true if obj%realm is allocated +pure logical function has_realm (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_realm = allocated(obj%realm) +end function has_realm +!> @brief Checks if obj%interp_method is allocated +!! @return true if obj%interp_method is allocated +pure logical function has_interp_method (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_interp_method = allocated(obj%interp_method) +end function has_interp_method +!> @brief Checks if obj%frequency is allocated +!! @return true if obj%frequency is allocated +pure logical function has_frequency (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_frequency = allocated(obj%frequency) +end function has_frequency +!> @brief Checks if obj%output_units is allocated +!! @return true if obj%output_units is allocated +pure logical function has_output_units (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_output_units = allocated(obj%output_units) +end function has_output_units +!> @brief Checks if obj%t is allocated +!! @return true if obj%t is allocated +pure logical function has_t (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_t = allocated(obj%t) +end function has_t +!> @brief Checks if obj%tile_count is allocated +!! @return true if obj%tile_count is allocated +pure logical function has_tile_count (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_tile_count = allocated(obj%tile_count) +end function has_tile_count +!> @brief Checks if obj%area is allocated +!! @return true if obj%area is allocated +pure logical function has_area (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_area = allocated(obj%area) +end function has_area +!> @brief Checks if obj%volume is allocated +!! @return true if obj%volume is allocated +pure logical function has_volume (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_volume = allocated(obj%volume) +end function has_volume +!> @brief Checks if obj%missing_value is allocated +!! @return true if obj%missing_value is allocated +pure logical function has_missing_value (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_missing_value = allocated(obj%missing_value) +end function has_missing_value +!> @brief Checks if obj%data_RANGE is allocated +!! @return true if obj%data_RANGE is allocated +pure logical function has_data_RANGE (obj) + class (fmsDiagField_type), intent(in) :: obj !< diag object + has_data_RANGE = allocated(obj%data_RANGE) +end function has_data_RANGE + + !> @brief Registers a scalar field + !! @return field index for subsequent call to send_data. + INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_time, & + & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,& + & area, volume, realm) + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + +#ifdef use_yaml + integer, allocatable :: diag_field_indices(:) !< indices where the field was found + + diag_field_indices = find_diag_field(field_name, module_name) + if (diag_field_indices(1) .eq. diag_null) then + !< The field was not found in the table, so return diag_null + fms_register_diag_field_scalar = diag_null + deallocate(diag_field_indices) + return + endif + + registered_variables = registered_variables + 1 + fms_register_diag_field_scalar = registered_variables + + call diag_objs(registered_variables)%setID(registered_variables) + call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, & + & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & + & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & + & area=area, volume=volume, realm=realm) + deallocate(diag_field_indices) +#endif + + end function fms_register_diag_field_scalar + + !> @brief Registers an array field + !> @return field index for subsequent call to send_data. + INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, init_time, & + & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,& + & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing. + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + +#ifdef use_yaml + integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found + + diag_field_indices = find_diag_field(field_name, module_name) + if (diag_field_indices(1) .eq. diag_null) then + !< The field was not found in the table, so return diag_null + fms_register_diag_field_array = diag_null + deallocate(diag_field_indices) + return + endif + + registered_variables = registered_variables + 1 + fms_register_diag_field_array = registered_variables + + call diag_objs(registered_variables)%setID(registered_variables) + call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, & + & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & + & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & + & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + deallocate(diag_field_indices) +#endif + +end function fms_register_diag_field_array + +!> @brief Return field index for subsequent call to send_data. +!! @return field index for subsequent call to send_data. +INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& + & tile_count, area, volume, realm) + CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute + CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to be added as a attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has + !! a mask variant + LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when + !! regridding the field in post-processing + !! Valid options are "conserve_order1", + !! "conserve_order2", and "none". + INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles + INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated + !! with this field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated + !! with this field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the + !! modeling_realm attribute + +#ifdef use_yaml + integer, allocatable :: diag_field_indices(:) !< indices where the field was foun + + diag_field_indices = find_diag_field(field_name, module_name) + if (diag_field_indices(1) .eq. diag_null) then + !< The field was not found in the table, so return diag_null + fms_register_static_field = diag_null + deallocate(diag_field_indices) + return + endif + + registered_variables = registered_variables + 1 + fms_register_static_field = registered_variables + + call diag_objs(registered_variables)%setID(registered_variables) + allocate(diag_objs(registered_variables)%static) + diag_objs(registered_variables)%static = .true. + call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, axes=axes, & + & longname=long_name, units=units, missing_value=missing_value, varrange=range, & + & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm) + deallocate(diag_field_indices) +#endif +end function fms_register_static_field + +!> @brief Get a pointer to the diag_object from the id. +!> @return A pointer to the diag_object or a null pointer if the id is not valid +FUNCTION get_diag_obj_from_id ( id ) result (obj_ptr) + integer :: id !< Id of the diag_obj to get + class(fmsDiagField_type), pointer :: obj_ptr + + obj_ptr => null() + IF (id >= 1 .and. id <= registered_variables) THEN + obj_ptr => diag_objs(id) + END IF +END FUNCTION get_diag_obj_from_id + +!> @brief Add a attribute to the diag_obj using the diag_field_id +subroutine fms_diag_field_add_attribute(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add + + type(fmsDiagField_type), pointer :: obj + + obj => get_diag_obj_from_id ( diag_field_id ) + if (.not. associated(obj)) return + + obj%num_attributes = obj%num_attributes + 1 + if (obj%num_attributes > max_field_attributes) & + call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"& + //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.") + + call obj%attributes(obj%num_attributes)%add(att_name, att_value) + nullify(obj) +end subroutine fms_diag_field_add_attribute + +!> @brief Determines the diag_obj id corresponding to a module name and field_name +!> @return diag_obj id +PURE FUNCTION fms_get_diag_field_id(module_name, field_name) & + result(diag_field_id) + + CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable + CHARACTER(len=*), INTENT(in) :: field_name !< Variable name + + integer :: diag_field_id + integer :: i !< For do loops + + diag_field_id = DIAG_FIELD_NOT_FOUND + do i = 1, registered_variables + if (diag_objs(i)%get_varname() .eq. trim(field_name) .and. & + diag_objs(i)%get_modname() .eq. trim(module_name)) then + diag_field_id = i + return + endif + enddo +end function fms_get_diag_field_id + +end module fms_diag_field_object_mod diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index f32958bc24..1f6cb1a3ae 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1,223 +1,32 @@ module fms_diag_object_mod -!> \author Tom Robinson -!> \email thomas.robinson@noaa.gov -!! \brief Contains routines for the diag_objects -!! -!! \description The diag_manager passes an object back and forth between the diag routines and the users. -!! The procedures of this object and the types are all in this module. The fms_dag_object is a type -!! that contains all of the information of the variable. It is extended by a type that holds the -!! appropriate buffer for the data for manipulation. -use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string -use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN -use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type -use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & - &DIAG_FIELD_NOT_FOUND +use fms_diag_file_object_mod :: FMS_diag_files +use fms_diag_field_object_mod :: fmsDiagField_type -use diag_axis_mod, only: diag_axis_type -use mpp_mod, only: fatal, note, warning, mpp_error -#ifdef use_yaml -use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, & - & find_diag_field, get_num_unique_fields -use fms_diag_file_object_mod, only: fmsDiagFile_type, FMS_diag_files -#endif -use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type -use time_manager_mod, ONLY: time_type -!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& -!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & -!!! & get_ticks_per_second - -use platform_mod -use iso_c_binding - -implicit none - -!> \brief Object that holds all variable information type fmsDiagObject_type -#ifdef use_yaml - type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable - integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable - !! belongs to -#endif - integer, allocatable, private :: diag_id !< unique id for varable - type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable - integer, private :: num_attributes !< Number of attributes currently added - logical, allocatable, private :: static !< true if this is a static var - logical, allocatable, private :: registered !< true when registered - logical, allocatable, private :: mask_variant !< If there is a mask variant - logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field - logical, allocatable, private :: local !< If the output is local - TYPE(time_type), private :: init_time !< The initial time - integer, allocatable, private :: vartype !< the type of varaible - character(len=:), allocatable, private :: varname !< the name of the variable - character(len=:), allocatable, private :: longname !< longname of the variable - character(len=:), allocatable, private :: standname !< standard name of the variable - character(len=:), allocatable, private :: units !< the units - character(len=:), allocatable, private :: modname !< the module - character(len=:), allocatable, private :: realm !< String to set as the value - !! to the modeling_realm attribute - character(len=:), allocatable, private :: interp_method !< The interp method to be used - !! when regridding the field in post-processing. - !! Valid options are "conserve_order1", - !! "conserve_order2", and "none". - integer, allocatable, dimension(:), private :: frequency !< specifies the frequency - integer, allocatable, dimension(:), private :: output_units - integer, allocatable, private :: t - integer, allocatable, private :: tile_count !< The number of tiles - integer, pointer, dimension(:), private :: axis_ids !< variable axis IDs - class(diagDomain_t), pointer, private :: domain !< Domain - INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", - !! "TWO_D_DOMAIN", or "UG_DOMAIN") - integer, allocatable, private :: area, volume !< The Area and Volume - class(*), allocatable, private :: missing_value !< The missing fill value - class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data - class(*), allocatable :: vardata0 !< Scalar data buffer - class(*), allocatable, dimension(:) :: vardata1 !< 1D data buffer - class(*), allocatable, dimension(:,:) :: vardata2 !< 2D data buffer - class(*), allocatable, dimension(:,:,:) :: vardata3 !< 3D data buffer - class(*), allocatable, dimension(:,:,:,:) :: vardata4 !< 4D data buffer - class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 !< 5D data buffer - contains -! procedure :: send_data => fms_send_data !!TODO - procedure :: init_ob => diag_obj_init - procedure :: get_id => fms_diag_get_id - procedure :: id => fms_diag_get_id - procedure :: copy => copy_diag_obj - procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. - procedure :: setID => set_diag_id - procedure :: set_type => set_vartype - procedure :: vartype_inq => what_is_vartype -! Check functions - procedure :: is_static => diag_obj_is_static - procedure :: is_registered => diag_ob_registered - procedure :: is_registeredB => diag_obj_is_registered - procedure :: is_mask_variant => get_mask_variant - procedure :: is_local => get_local -! Is variable allocated check functions -!TODO procedure :: has_diag_field - procedure :: has_diag_id - procedure :: has_attributes - procedure :: has_static - procedure :: has_registered - procedure :: has_mask_variant - procedure :: has_local -!TODO procedure :: has_init_time - procedure :: has_vartype - procedure :: has_varname - procedure :: has_longname - procedure :: has_standname - procedure :: has_units - procedure :: has_modname - procedure :: has_realm - procedure :: has_interp_method - procedure :: has_frequency - procedure :: has_output_units - procedure :: has_t - procedure :: has_tile_count - procedure :: has_area - procedure :: has_volume - procedure :: has_missing_value - procedure :: has_data_RANGE -! Get functions - procedure :: get_diag_id => fms_diag_get_id - procedure :: get_attributes - procedure :: get_static - procedure :: get_registered - procedure :: get_mask_variant - procedure :: get_local - procedure :: get_vartype - procedure :: get_varname - procedure :: get_longname - procedure :: get_standname - procedure :: get_units - procedure :: get_modname - procedure :: get_realm - procedure :: get_interp_method - procedure :: get_frequency - procedure :: get_output_units - procedure :: get_t - procedure :: get_tile_count - procedure :: get_area - procedure :: get_volume - procedure :: get_missing_value - procedure :: get_data_RANGE -!TODO procedure :: get_init_time -!TODO procedure :: get_axis +!TODO add container arrays + TYPE(fmsDiagField_type), private, ALLOCATABLE, target :: diag_fields(:) !< Array of diag objects + !! one for each registered variable + integer, private :: registered_variables !< Number of registered variables + contains + procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. end type fmsDiagObject_type -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -type(fmsDiagObject_type) :: null_ob -integer,private :: MAX_LEN_VARNAME -integer,private :: MAX_LEN_META -logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized +type (fmsDiagObject_type), target :: fms_diag_object -TYPE(fmsDiagObject_type), private, ALLOCATABLE, target :: diag_objs(:) !< Array of diag objects - !! one for each registered variable -integer, private :: registered_variables !< Number of registered variables - -!type(fmsDiagObject_type) :: diag_object_placeholder (10) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -public :: fmsDiagObject_type -public :: null_ob -public :: copy_diag_obj, fms_diag_get_id -public :: fms_diag_object_init -public :: fms_diag_object_end -public :: fms_register_diag_field_array +public :: fms_register_diag_field_obj public :: fms_register_diag_field_scalar +public :: fms_register_diag_field_array public :: fms_register_static_field -public :: fms_diag_field_add_attribute -public :: get_diag_obj_from_id -public :: fms_get_diag_field_id -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CONTAINS -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> @brief Initiliazes the array of diag_objs based on the number of unique diag_fields in the diag_table -subroutine fms_diag_object_init (mlv,mlm) - integer, intent(in) :: mlv !< The maximum length of the varname - integer, intent(in) :: mlm !< The maximum length of the metadata - - if (module_is_initialized) return - -!> Get info from the namelist - MAX_LEN_VARNAME = mlv - MAX_LEN_META = mlm -!> Initialize the null_d variables - null_ob%diag_id = DIAG_NULL -#ifdef use_yaml - allocate(diag_objs(get_num_unique_fields())) - registered_variables = 0 -#endif - module_is_initialized = .true. -end subroutine fms_diag_object_init - -!> @brief Deallocates the array of diag_objs -subroutine fms_diag_object_end () - if (.not. module_is_initialized) return - - if (allocated(diag_objs)) deallocate(diag_objs) - - module_is_initialized = .false. -end subroutine fms_diag_object_end -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \Description Sets the diag_id to the not registered value. -subroutine diag_obj_init(ob) - class (fmsDiagObject_type) , intent(inout) :: ob - select type (ob) - class is (fmsDiagObject_type) - ob%diag_id = diag_not_registered !null_ob%diag_id - ob%registered = .false. - end select -end subroutine diag_obj_init -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +public :: fms_diag_object +contains !> \Description Fills in and allocates (when necessary) the values in the diagnostic object subroutine fms_register_diag_field_obj & - !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata) - (dobj, modname, varname, diag_field_indices, axes, init_time, & + !(field_obj, modname, varname, axes, time, longname, units, missing_value, metadata) + (fms_diag_object, modname, varname, diag_field_indices, axes, init_time, & longname, units, missing_value, varRange, mask_variant, standname, & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) - class(fmsDiagObject_type), INTENT(inout) :: dobj !< Diaj_obj to fill + class(fmsDiagObject_type), INTENT(inout) :: fms_diag_object !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: modname !< The module name CHARACTER(len=*), INTENT(in) :: varname !< The variable name integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field @@ -243,23 +52,23 @@ subroutine fms_register_diag_field_obj & !! modeling_realm attribute integer :: i !< For do loops - integer :: j !< dobj%file_ids(i) (for less typing :) + integer :: j !< fms_diag_object%field_obj%file_ids(i) (for less typing :) #ifdef use_yaml !> Fill in information from the register call - dobj%varname = trim(varname) - dobj%modname = trim(modname) + fms_diag_object%field_obj%varname = trim(varname) + fms_diag_object%field_obj%modname = trim(modname) !> Fill in diag_field and find the ids of the files that this variable is in - dobj%diag_field = get_diag_fields_entries(diag_field_indices) - dobj%file_ids = get_diag_files_id(diag_field_indices) + fms_diag_object%field_obj%diag_field = get_diag_fields_entries(diag_field_indices) + fms_diag_object%field_obj%file_ids = get_diag_files_id(diag_field_indices) if (present(axes)) then - dobj%axis_ids => axes - call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname) - do i = 1, size(dobj%file_ids) - j = dobj%file_ids(i) - call FMS_diag_files(j)%set_file_domain(dobj%domain, dobj%type_of_domain) + fms_diag_object%field_obj%axis_ids => axes + call get_domain_and_domain_type(fms_diag_object%field_obj%axis_ids, fms_diag_object%field_obj%type_of_domain, fms_diag_object%field_obj%domain, fms_diag_object%field_obj%varname) + do i = 1, size(fms_diag_object%field_obj%file_ids) + j = fms_diag_object%field_obj%file_ids(i) + call FMS_diag_files(j)%set_file_domain(fms_diag_object%field_obj%domain, fms_diag_object%field_obj%type_of_domain) call FMS_diag_files(j)%add_axes(axes) if (present(init_time)) call FMS_diag_files(j)%add_start_time(init_time) enddo @@ -267,43 +76,43 @@ subroutine fms_register_diag_field_obj & !! Mark the field as registered in the diag_files else !> The variable is a scalar - dobj%type_of_domain = NO_DOMAIN - dobj%domain => null() + fms_diag_object%field_obj%type_of_domain = NO_DOMAIN + fms_diag_object%field_obj%domain => null() endif !> get the optional arguments if included and the diagnostic is in the diag table - if (present(longname)) dobj%longname = trim(longname) - if (present(standname)) dobj%standname = trim(standname) - if (present(units)) dobj%units = trim(units) - if (present(realm)) dobj%realm = trim(realm) - if (present(interp_method)) dobj%interp_method = trim(interp_method) + if (present(longname)) fms_diag_object%field_obj%longname = trim(longname) + if (present(standname)) fms_diag_object%field_obj%standname = trim(standname) + if (present(units)) fms_diag_object%field_obj%units = trim(units) + if (present(realm)) fms_diag_object%field_obj%realm = trim(realm) + if (present(interp_method)) fms_diag_object%field_obj%interp_method = trim(interp_method) if (present(tile_count)) then - allocate(dobj%tile_count) - dobj%tile_count = tile_count + allocate(fms_diag_object%field_obj%tile_count) + fms_diag_object%field_obj%tile_count = tile_count endif if (present(missing_value)) then select type (missing_value) type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: dobj%missing_value) - dobj%missing_value = missing_value + allocate(integer(kind=i4_kind) :: fms_diag_object%field_obj%missing_value) + fms_diag_object%field_obj%missing_value = missing_value type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: dobj%missing_value) - dobj%missing_value = missing_value + allocate(integer(kind=i8_kind) :: fms_diag_object%field_obj%missing_value) + fms_diag_object%field_obj%missing_value = missing_value type is (real(kind=r4_kind)) - allocate(integer(kind=r4_kind) :: dobj%missing_value) - dobj%missing_value = missing_value + allocate(integer(kind=r4_kind) :: fms_diag_object%field_obj%missing_value) + fms_diag_object%field_obj%missing_value = missing_value type is (real(kind=r8_kind)) - allocate(integer(kind=r8_kind) :: dobj%missing_value) - dobj%missing_value = missing_value + allocate(integer(kind=r8_kind) :: fms_diag_object%field_obj%missing_value) + fms_diag_object%field_obj%missing_value = missing_value class default call mpp_error("fms_register_diag_field_obj", & "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",& FATAL) end select else - allocate(real :: dobj%missing_value) - select type (miss => dobj%missing_value) + allocate(real :: fms_diag_object%field_obj%missing_value) + select type (miss => fms_diag_object%field_obj%missing_value) type is (real) miss = real(CMOR_MISSING_VALUE) end select @@ -312,25 +121,25 @@ subroutine fms_register_diag_field_obj & if (present(varRANGE)) then select type (varRANGE) type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: dobj%data_RANGE(2)) - dobj%data_RANGE = varRANGE + allocate(integer(kind=i4_kind) :: fms_diag_object%field_obj%data_RANGE(2)) + fms_diag_object%field_obj%data_RANGE = varRANGE type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: dobj%data_RANGE(2)) - dobj%data_RANGE = varRANGE + allocate(integer(kind=i8_kind) :: fms_diag_object%field_obj%data_RANGE(2)) + fms_diag_object%field_obj%data_RANGE = varRANGE type is (real(kind=r4_kind)) - allocate(integer(kind=r4_kind) :: dobj%data_RANGE(2)) - dobj%data_RANGE = varRANGE + allocate(integer(kind=r4_kind) :: fms_diag_object%field_obj%data_RANGE(2)) + fms_diag_object%field_obj%data_RANGE = varRANGE type is (real(kind=r8_kind)) - allocate(integer(kind=r8_kind) :: dobj%data_RANGE(2)) - dobj%data_RANGE = varRANGE + allocate(integer(kind=r8_kind) :: fms_diag_object%field_obj%data_RANGE(2)) + fms_diag_object%field_obj%data_RANGE = varRANGE class default call mpp_error("fms_register_diag_field_obj", & "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",& FATAL) end select else - allocate(real :: dobj%data_RANGE(2)) - select type (varRANGE => dobj%data_RANGE) + allocate(real :: fms_diag_object%field_obj%data_RANGE(2)) + select type (varRANGE => fms_diag_object%field_obj%data_RANGE) type is (real) varRANGE = real(CMOR_MISSING_VALUE) end select @@ -341,8 +150,8 @@ subroutine fms_register_diag_field_obj & "The area id passed with field_name"//trim(varname)//" has not been registered."& "Check that there is a register_diag_field call for the AREA measure and that is in the"& "diag_table.yaml", FATAL) - allocate(dobj%area) - dobj%area = area + allocate(fms_diag_object%field_obj%area) + fms_diag_object%field_obj%area = area endif if (present(volume)) then @@ -350,629 +159,27 @@ subroutine fms_register_diag_field_obj & "The volume id passed with field_name"//trim(varname)//" has not been registered."& "Check that there is a register_diag_field call for the VOLUME measure and that is in the"& "diag_table.yaml", FATAL) - allocate(dobj%volume) - dobj%volume = volume + allocate(fms_diag_object%field_obj%volume) + fms_diag_object%field_obj%volume = volume endif if (present(mask_variant)) then - allocate(dobj%mask_variant) - dobj%mask_variant = mask_variant + allocate(fms_diag_object%field_obj%mask_variant) + fms_diag_object%field_obj%mask_variant = mask_variant endif if (present(do_not_log)) then - allocate(dobj%do_not_log) - dobj%do_not_log = do_not_log + allocate(fms_diag_object%field_obj%do_not_log) + fms_diag_object%field_obj%do_not_log = do_not_log endif !< Allocate space for any additional variable attributes !< These will be fill out when calling `diag_field_add_attribute` - allocate(dobj%attributes(max_field_attributes)) - dobj%num_attributes = 0 - dobj%registered = .true. + allocate(fms_diag_object%field_obj%attributes(max_field_attributes)) + fms_diag_object%field_obj%num_attributes = 0 + fms_diag_object%field_obj%registered = .true. #endif end subroutine fms_register_diag_field_obj -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \brief Sets the diag_id. This can only be done if a variable is unregistered -subroutine set_diag_id(objin , id) - class (fmsDiagObject_type) , intent(inout):: objin - integer :: id - if (allocated(objin%registered)) then - if (objin%registered) then - call mpp_error("set_diag_id", "The variable"//objin%varname//" is already registered", FATAL) - endif - else - objin%diag_id = id - endif -end subroutine set_diag_id -!> \brief Find the type of the variable and store it in the object -subroutine set_vartype(objin , var) - class (fmsDiagObject_type) , intent(inout):: objin - class(*) :: var - select type (var) - type is (real(kind=8)) - objin%vartype = r8 - type is (real(kind=4)) - objin%vartype = r4 - type is (integer(kind=8)) - objin%vartype = i8 - type is (integer(kind=4)) - objin%vartype = i4 - type is (character(*)) - objin%vartype = string - class default - objin%vartype = null_type_int - call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// & - " r8, r4, i8, i4, or string.", warning) - end select -end subroutine set_vartype -!> \brief Prints to the screen what type the diag variable is -subroutine what_is_vartype(objin) - class (fmsDiagObject_type) , intent(inout):: objin - if (.not. allocated(objin%vartype)) then - call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning) - return - endif - select case (objin%vartype) - case (r8) - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " is REAL(kind=8)", NOTE) - case (r4) - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " is REAL(kind=4)", NOTE) - case (i8) - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " is INTEGER(kind=8)", NOTE) - case (i4) - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " is INTEGER(kind=4)", NOTE) - case (string) - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " is CHARACTER(*)", NOTE) - case (null_type_int) - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " was not set", WARNING) - case default - call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//& - " is not supported by diag_manager", FATAL) - end select -end subroutine what_is_vartype -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!MZ Is this a TODO. Many problems: -!> \brief Registers the object -subroutine diag_ob_registered(objin , reg) - class (fmsDiagObject_type) , intent(inout):: objin - logical , intent(in) :: reg !< If registering, this is true - objin%registered = reg -end subroutine diag_ob_registered -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \brief Copies the calling object into the object that is the argument of the subroutine -subroutine copy_diag_obj(objin , objout) - class (fmsDiagObject_type) , intent(in) :: objin - class (fmsDiagObject_type) , intent(inout) , allocatable :: objout !< The destination of the copy -select type (objout) - class is (fmsDiagObject_type) - - if (allocated(objin%registered)) then - objout%registered = objin%registered - else - call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning) - endif - objout%diag_id = objin%diag_id - - if (allocated(objin%attributes)) objout%attributes = objin%attributes - objout%static = objin%static - if (allocated(objin%frequency)) objout%frequency = objin%frequency - if (allocated(objin%varname)) objout%varname = objin%varname -end select -end subroutine copy_diag_obj -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \brief Returns the ID integer for a variable -!! \return the diag ID -integer function fms_diag_get_id (dobj) result(diag_id) - class(fmsDiagObject_type) , intent(inout) :: dobj -! character(*) , intent(in) :: varname -!> Check if the diag_object registration has been done - if (allocated(dobj%registered)) then - !> Return the diag_id if the variable has been registered - diag_id = dobj%diag_id - else -!> If the variable is not regitered, then return the unregistered value - diag_id = DIAG_NOT_REGISTERED - endif -end function fms_diag_get_id - -!> Function to return a character (string) representation of the most basic -!> object identity info. Intended for debugging and warning. The format produced is: -!> [dobj: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)]. -!> A questionmark "?" is set in place of the variable that is not yet allocated -!>TODO: Add diag_id ? -function fms_diag_obj_as_string_basic(dobj) result(rslt) - class(fmsDiagObject_type), allocatable, intent(in) :: dobj - character(:), allocatable :: rslt - character (len=:), allocatable :: registered, vartype, varname, diag_id - if ( .not. allocated (dobj)) then - varname = "?" - vartype = "?" - registered = "?" - diag_id = "?" - rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]" - return - end if - -! if(allocated (dobj%registered)) then -! registered = logical_to_cs (dobj%registered) -! else -! registered = "?" -! end if - -! if(allocated (dobj%diag_id)) then -! diag_id = int_to_cs (dobj%diag_id) -! else -! diag_id = "?" -! end if - -! if(allocated (dobj%vartype)) then -! vartype = int_to_cs (dobj%vartype) -! else -! registered = "?" -! end if - - if(allocated (dobj%varname)) then - varname = dobj%varname - else - registered = "?" - end if - - rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]" - -end function fms_diag_obj_as_string_basic - - -function diag_obj_is_registered (obj) result (rslt) - class(fmsDiagObject_type), intent(in) :: obj - logical :: rslt - rslt = obj%registered -end function diag_obj_is_registered - -function diag_obj_is_static (obj) result (rslt) - class(fmsDiagObject_type), intent(in) :: obj - logical :: rslt - rslt = obj%static -end function diag_obj_is_static - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! Get functions - -!> @brief Gets attributes -!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes -function get_attributes (obj) & -result(rslt) - class (fmsDiagObject_type), target, intent(in) :: obj !< diag object - type(fmsDiagAttribute_type), pointer :: rslt(:) - - rslt => null() - if (obj%num_attributes > 0 ) rslt => obj%attributes -end function get_attributes -!> @brief Gets static -!! @return copy of variable static -pure function get_static (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - logical :: rslt - rslt = obj%static -end function get_static -!> @brief Gets regisetered -!! @return copy of registered -pure function get_registered (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - logical :: rslt - rslt = obj%registered -end function get_registered -!> @brief Gets mask variant -!! @return copy of mask variant -pure function get_mask_variant (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - logical :: rslt - rslt = obj%mask_variant -end function get_mask_variant -!> @brief Gets local -!! @return copy of local -pure function get_local (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - logical :: rslt - rslt = obj%local -end function get_local -!> @brief Gets initial time -!! @return copy of the initial time -!! TODO -!function get_init_time (obj) & -!result(rslt) -! class (fmsDiagObject_type), intent(in) :: obj !< diag object -! TYPE(time_type) :: rslt -! -!end function get_init_time -!> @brief Gets vartype -!! @return copy of The integer related to the variable type -pure function get_vartype (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer :: rslt - rslt = obj%vartype -end function get_vartype -!> @brief Gets varname -!! @return copy of the variable name -pure function get_varname (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - rslt = obj%varname -end function get_varname -!> @brief Gets longname -!! @return copy of the variable long name or a single string if there is no long name -pure function get_longname (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - if (allocated(obj%longname)) then - rslt = obj%longname - else - rslt = diag_null_string - endif -end function get_longname -!> @brief Gets standname -!! @return copy of the standard name or an empty string if standname is not allocated -pure function get_standname (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - if (allocated(obj%standname)) then - rslt = obj%standname - else - rslt = diag_null_string - endif -end function get_standname -!> @brief Gets units -!! @return copy of the units or an empty string if not allocated -pure function get_units (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - if (allocated(obj%units)) then - rslt = obj%units - else - rslt = diag_null_string - endif -end function get_units -!> @brief Gets modname -!! @return copy of the module name that the variable is in or an empty string if not allocated -pure function get_modname (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - if (allocated(obj%modname)) then - rslt = obj%modname - else - rslt = diag_null_string - endif -end function get_modname -!> @brief Gets realm -!! @return copy of the variables modeling realm or an empty string if not allocated -pure function get_realm (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - if (allocated(obj%realm)) then - rslt = obj%realm - else - rslt = diag_null_string - endif -end function get_realm -!> @brief Gets interp_method -!! @return copy of The interpolation method or an empty string if not allocated -pure function get_interp_method (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - character(len=:), allocatable :: rslt - if (allocated(obj%interp_method)) then - rslt = obj%interp_method - else - rslt = diag_null_string - endif -end function get_interp_method -!> @brief Gets frequency -!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated -pure function get_frequency (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer, allocatable, dimension (:) :: rslt - if (allocated(obj%frequency)) then - allocate (rslt(size(obj%frequency))) - rslt = obj%frequency - else - allocate (rslt(1)) - rslt = DIAG_NULL - endif -end function get_frequency -!> @brief Gets output_units -!! @return copy of The units of the output or DIAG_NULL is output_units is not allocated -pure function get_output_units (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer,allocatable, dimension (:) :: rslt - if (allocated(obj%output_units)) then - allocate (rslt(size(obj%output_units))) - rslt = obj%output_units - else - allocate (rslt(1)) - rslt = DIAG_NULL - endif -end function get_output_units -!> @brief Gets t -!! @return copy of t -pure function get_t (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer :: rslt - if (allocated(obj%t)) then - rslt = obj%t - else - rslt = -999 - endif -end function get_t -!> @brief Gets tile_count -!! @return copy of the number of tiles or diag_null if tile_count is not allocated -pure function get_tile_count (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer :: rslt - if (allocated(obj%tile_count)) then - rslt = obj%tile_count - else - rslt = DIAG_NULL - endif -end function get_tile_count -!> @brief Gets area -!! @return copy of the area or diag_null if not allocated -pure function get_area (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer :: rslt - if (allocated(obj%area)) then - rslt = obj%area - else - rslt = diag_null - endif -end function get_area -!> @brief Gets volume -!! @return copy of the volume or diag_null if volume is not allocated -pure function get_volume (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - integer :: rslt - if (allocated(obj%volume)) then - rslt = obj%volume - else - rslt = diag_null - endif -end function get_volume -!> @brief Gets missing_value -!! @return copy of The missing value -function get_missing_value (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - class(*),allocatable :: rslt - if (allocated(obj%missing_value)) then - select type (miss => obj%missing_value) - type is (integer(kind=i4_kind)) - allocate (integer(kind=i4_kind) :: rslt) - rslt = miss - type is (integer(kind=i8_kind)) - allocate (integer(kind=i8_kind) :: rslt) - rslt = miss - type is (real(kind=r4_kind)) - allocate (integer(kind=i4_kind) :: rslt) - rslt = miss - type is (real(kind=r8_kind)) - allocate (integer(kind=i4_kind) :: rslt) - rslt = miss - class default - call mpp_error ("get_missing_value", & - "The missing value is not a r8, r4, i8, or i4",& - FATAL) - end select - else - call mpp_error ("get_missing_value", & - "The missing value is not allocated", FATAL) - endif -end function get_missing_value -!> @brief Gets data_range -!! @return copy of the data range -function get_data_RANGE (obj) & -result(rslt) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - class(*),allocatable :: rslt(:) - if (allocated(obj%data_RANGE)) then - select type (r => obj%data_RANGE) - type is (integer(kind=i4_kind)) - allocate (integer(kind=i4_kind) :: rslt(2)) - rslt = r - type is (integer(kind=i8_kind)) - allocate (integer(kind=i8_kind) :: rslt(2)) - rslt = r - type is (real(kind=r4_kind)) - allocate (integer(kind=i4_kind) :: rslt(2)) - rslt = r - type is (real(kind=r8_kind)) - allocate (integer(kind=i4_kind) :: rslt(2)) - rslt = r - class default - call mpp_error ("get_data_RANGE", & - "The data_RANGE value is not a r8, r4, i8, or i4",& - FATAL) - end select - else - call mpp_error ("get_data_RANGE", & - "The data_RANGE value is not allocated", FATAL) - endif -end function get_data_RANGE -!> @brief Gets axis -!! @return copy of axis information -!! TODO -!function get_axis (obj) & -!result(rslt) -! class (fmsDiagObject_type), intent(in) :: obj !< diag object -! type (diag_axis_type), allocatable, dimension(:) :: rslt -! -!end function get_axis -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!! Allocation checks -!!> @brief Checks if obj%diag_field is allocated -!!! @return true if obj%diag_field is allocated -!logical function has_diag_field (obj) -! class (fmsDiagObject_type), intent(in) :: obj !< diag object -! has_diag_field = allocated(obj%diag_field) -!end function has_diag_field -!> @brief Checks if obj%diag_id is allocated -!! @return true if obj%diag_id is allocated -pure logical function has_diag_id (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_diag_id = allocated(obj%diag_id) -end function has_diag_id -!> @brief Checks if obj%metadata is allocated -!! @return true if obj%metadata is allocated -pure logical function has_attributes (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_attributes = obj%num_attributes > 0 -end function has_attributes -!> @brief Checks if obj%static is allocated -!! @return true if obj%static is allocated -pure logical function has_static (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_static = allocated(obj%static) -end function has_static -!> @brief Checks if obj%registered is allocated -!! @return true if obj%registered is allocated -pure logical function has_registered (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_registered = allocated(obj%registered) -end function has_registered -!> @brief Checks if obj%mask_variant is allocated -!! @return true if obj%mask_variant is allocated -pure logical function has_mask_variant (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_mask_variant = allocated(obj%mask_variant) -end function has_mask_variant -!> @brief Checks if obj%local is allocated -!! @return true if obj%local is allocated -pure logical function has_local (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_local = allocated(obj%local) -end function has_local -!!> @brief Checks if obj%init_time is allocated -!!! @return true if obj%init_time is allocated -!logical function has_init_time (obj) -! class (fmsDiagObject_type), intent(in) :: obj !< diag object -! has_init_time = allocated(obj%init_time) -!end function has_init_time -!> @brief Checks if obj%vartype is allocated -!! @return true if obj%vartype is allocated -pure logical function has_vartype (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_vartype = allocated(obj%vartype) -end function has_vartype -!> @brief Checks if obj%varname is allocated -!! @return true if obj%varname is allocated -pure logical function has_varname (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_varname = allocated(obj%varname) -end function has_varname -!> @brief Checks if obj%longname is allocated -!! @return true if obj%longname is allocated -pure logical function has_longname (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_longname = allocated(obj%longname) -end function has_longname -!> @brief Checks if obj%standname is allocated -!! @return true if obj%standname is allocated -pure logical function has_standname (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_standname = allocated(obj%standname) -end function has_standname -!> @brief Checks if obj%units is allocated -!! @return true if obj%units is allocated -pure logical function has_units (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_units = allocated(obj%units) -end function has_units -!> @brief Checks if obj%modname is allocated -!! @return true if obj%modname is allocated -pure logical function has_modname (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_modname = allocated(obj%modname) -end function has_modname -!> @brief Checks if obj%realm is allocated -!! @return true if obj%realm is allocated -pure logical function has_realm (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_realm = allocated(obj%realm) -end function has_realm -!> @brief Checks if obj%interp_method is allocated -!! @return true if obj%interp_method is allocated -pure logical function has_interp_method (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_interp_method = allocated(obj%interp_method) -end function has_interp_method -!> @brief Checks if obj%frequency is allocated -!! @return true if obj%frequency is allocated -pure logical function has_frequency (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_frequency = allocated(obj%frequency) -end function has_frequency -!> @brief Checks if obj%output_units is allocated -!! @return true if obj%output_units is allocated -pure logical function has_output_units (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_output_units = allocated(obj%output_units) -end function has_output_units -!> @brief Checks if obj%t is allocated -!! @return true if obj%t is allocated -pure logical function has_t (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_t = allocated(obj%t) -end function has_t -!> @brief Checks if obj%tile_count is allocated -!! @return true if obj%tile_count is allocated -pure logical function has_tile_count (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_tile_count = allocated(obj%tile_count) -end function has_tile_count -!> @brief Checks if obj%area is allocated -!! @return true if obj%area is allocated -pure logical function has_area (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_area = allocated(obj%area) -end function has_area -!> @brief Checks if obj%volume is allocated -!! @return true if obj%volume is allocated -pure logical function has_volume (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_volume = allocated(obj%volume) -end function has_volume -!> @brief Checks if obj%missing_value is allocated -!! @return true if obj%missing_value is allocated -pure logical function has_missing_value (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_missing_value = allocated(obj%missing_value) -end function has_missing_value -!> @brief Checks if obj%data_RANGE is allocated -!! @return true if obj%data_RANGE is allocated -pure logical function has_data_RANGE (obj) - class (fmsDiagObject_type), intent(in) :: obj !< diag object - has_data_RANGE = allocated(obj%data_RANGE) -end function has_data_RANGE !> @brief Registers a scalar field !! @return field index for subsequent call to send_data. @@ -1121,57 +328,5 @@ INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_n #endif end function fms_register_static_field -!> @brief Get a pointer to the diag_object from the id. -!> @return A pointer to the diag_object or a null pointer if the id is not valid -FUNCTION get_diag_obj_from_id ( id ) result (obj_ptr) - integer :: id !< Id of the diag_obj to get - class(fmsDiagObject_type), pointer :: obj_ptr - - obj_ptr => null() - IF (id >= 1 .and. id <= registered_variables) THEN - obj_ptr => diag_objs(id) - END IF -END FUNCTION get_diag_obj_from_id - -!> @brief Add a attribute to the diag_obj using the diag_field_id -subroutine fms_diag_field_add_attribute(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to - character(len=*), intent(in) :: att_name !< Name of the attribute - class(*), intent(in) :: att_value(:) !< The attribute value to add - - type(fmsDiagObject_type), pointer :: obj - - obj => get_diag_obj_from_id ( diag_field_id ) - if (.not. associated(obj)) return - - obj%num_attributes = obj%num_attributes + 1 - if (obj%num_attributes > max_field_attributes) & - call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"& - //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.") - - call obj%attributes(obj%num_attributes)%add(att_name, att_value) - nullify(obj) -end subroutine fms_diag_field_add_attribute - -!> @brief Determines the diag_obj id corresponding to a module name and field_name -!> @return diag_obj id -PURE FUNCTION fms_get_diag_field_id(module_name, field_name) & - result(diag_field_id) - - CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable - CHARACTER(len=*), INTENT(in) :: field_name !< Variable name - - integer :: diag_field_id - integer :: i !< For do loops - - diag_field_id = DIAG_FIELD_NOT_FOUND - do i = 1, registered_variables - if (diag_objs(i)%get_varname() .eq. trim(field_name) .and. & - diag_objs(i)%get_modname() .eq. trim(module_name)) then - diag_field_id = i - return - endif - enddo -end function fms_get_diag_field_id -end module fms_diag_object_mod +end fms_diag_object_mod diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90 index ea37390dbe..8e397720a1 100644 --- a/diag_manager/fms_diag_object_container.F90 +++ b/diag_manager/fms_diag_object_container.F90 @@ -20,12 +20,12 @@ !> @defgroup fms_diag_object_container_mod fms_diag_object_container_mod !> @ingroup diag_manager !> @brief fms_diag_object_container_mod defines a container class and iterator class -!! for inserting, removing and searching for fmsDiagObject_type instances +!! for inserting, removing and searching for fmsDiagField_type instances !! !> @author Miguel Zuniga !! !! fms_diag_object_container_mod defines a container for inserting, removing and -!! searching for fmsDiagObject_type instances. It also defined an iterator for +!! searching for fmsDiagField_type instances. It also defined an iterator for !! the data in the container. The value returned by the fms_diag_object function get_id() !! is used for search key comparison. !! @@ -40,7 +40,7 @@ !> @addtogroup fms_diag_object_container_mod !> @{ MODULE fms_diag_object_container_mod - use fms_diag_object_mod, only: fmsDiagObject_type + use fms_diag_field_object_mod, only: fmsDiagField_type USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE !! Since this version is based on the FDS linked list: @@ -48,7 +48,7 @@ MODULE fms_diag_object_container_mod implicit none - !> @brief A container of fmsDiagObject_type instances providing insert, remove , + !> @brief A container of fmsDiagField_type instances providing insert, remove , !! find/search, and size public member functions. Iterator is provided by !! the associated iterator class (see dig_obj_iterator class). !! @@ -101,7 +101,7 @@ function find_diag_object (this, id , iiter) result (riter) class(FmsDiagObjIterator_t), intent (in), optional :: iiter !< An (optional) iterator over the searchable set. class(FmsDiagObjIterator_t) , allocatable :: riter !< The resultant iterator to the object. - class(fmsDiagObject_type), pointer:: ptdo !< A pointer to temporaty diagnostic object + class(fmsDiagField_type), pointer:: ptdo !< A pointer to temporaty diagnostic object integer :: status !< A status from iterator operations. !! if(present (iiter)) then @@ -126,7 +126,7 @@ end function find_diag_object function insert_diag_object (this, id, obj) result (status) class (FmsDiagObjectContainer_t), intent (in out) :: this integer, intent (in) :: id !< The id of the object to insert. - class(fmsDiagObject_type) , intent (in out) :: obj !< The object to insert + class(fmsDiagField_type) , intent (in out) :: obj !< The object to insert integer :: status !< The returned status. 0 for success. class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator. @@ -243,13 +243,13 @@ end function literator_next function literator_data( this ) result( rdo ) class(FmsDiagObjIterator_t), intent(in) :: this ! null() gp => this%liter%get() select type(gp) - type is (fmsDiagObject_type) !! "type is", not the (polymorphic) "class is" + type is (fmsDiagField_type) !! "type is", not the (polymorphic) "class is" rdo => gp class default call error_mesg ('fms_diag_object_container:', & From 8f480ba1675cc06cd36f8743f4ed297e130d0b7a Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Tue, 9 Aug 2022 15:23:55 -0400 Subject: [PATCH 02/11] Adds licesne --- diag_manager/fms_diag_object.F90 | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 1f6cb1a3ae..aa6e801d9d 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1,3 +1,21 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** module fms_diag_object_mod use fms_diag_file_object_mod :: FMS_diag_files use fms_diag_field_object_mod :: fmsDiagField_type From 1a705f6b9fac6f7c2647be96157cd598ca7a3be7 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 10 Aug 2022 12:28:41 -0400 Subject: [PATCH 03/11] Adds inits for object, file and field --- diag_manager/fms_diag_field_object.F90 | 68 +++++++++----------------- diag_manager/fms_diag_file_object.F90 | 10 ++-- diag_manager/fms_diag_object.F90 | 55 +++++++++++++++++++-- 3 files changed, 79 insertions(+), 54 deletions(-) diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index 3d078e1254..441456683e 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -69,15 +69,9 @@ module fms_diag_field_object_mod integer, allocatable, private :: area, volume !< The Area and Volume class(*), allocatable, private :: missing_value !< The missing fill value class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data - class(*), allocatable :: vardata0 !< Scalar data buffer - class(*), allocatable, dimension(:) :: vardata1 !< 1D data buffer - class(*), allocatable, dimension(:,:) :: vardata2 !< 2D data buffer - class(*), allocatable, dimension(:,:,:) :: vardata3 !< 3D data buffer - class(*), allocatable, dimension(:,:,:,:) :: vardata4 !< 4D data buffer - class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 !< 5D data buffer contains ! procedure :: send_data => fms_send_data !!TODO - procedure :: init_ob => diag_obj_init + procedure :: init_ob => fms_diag_fields_object_init procedure :: get_id => fms_diag_get_id procedure :: id => fms_diag_get_id procedure :: copy => copy_diag_obj @@ -145,17 +139,13 @@ module fms_diag_field_object_mod !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type(fmsDiagField_type) :: null_ob -integer,private :: MAX_LEN_VARNAME -integer,private :: MAX_LEN_META logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized - -TYPE(fmsDiagField_type), private, ALLOCATABLE, target :: diag_objs(:) !< Array of diag objects - !! one for each registered variable integer, private :: registered_variables !< Number of registered variables !type(fmsDiagField_type) :: diag_object_placeholder (10) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! public :: fmsDiagField_type +public :: fms_diag_fields_object_init public :: null_ob public :: copy_diag_obj, fms_diag_get_id public :: fms_diag_object_init @@ -171,43 +161,31 @@ module fms_diag_field_object_mod CONTAINS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> @brief Initiliazes the array of diag_objs based on the number of unique diag_fields in the diag_table -subroutine fms_diag_object_init (mlv,mlm) - integer, intent(in) :: mlv !< The maximum length of the varname - integer, intent(in) :: mlm !< The maximum length of the metadata - - if (module_is_initialized) return - -!> Get info from the namelist - MAX_LEN_VARNAME = mlv - MAX_LEN_META = mlm -!> Initialize the null_d variables - null_ob%diag_id = DIAG_NULL -#ifdef use_yaml - allocate(diag_objs(get_num_unique_fields())) - registered_variables = 0 -#endif - module_is_initialized = .true. -end subroutine fms_diag_object_init !> @brief Deallocates the array of diag_objs -subroutine fms_diag_object_end () - if (.not. module_is_initialized) return - - if (allocated(diag_objs)) deallocate(diag_objs) - +subroutine fms_diag_object_end (ob) + class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object + if (allocated(ob)) deallocate(ob) module_is_initialized = .false. end subroutine fms_diag_object_end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \Description Sets the diag_id to the not registered value. -subroutine diag_obj_init(ob) - class (fmsDiagField_type) , intent(inout) :: ob - select type (ob) - class is (fmsDiagField_type) - ob%diag_id = diag_not_registered !null_ob%diag_id - ob%registered = .false. - end select -end subroutine diag_obj_init +!> \Description Allocates the diad field object array. +!! Sets the diag_id to the not registered value. +!! Initializes the number of registered variables to be 0 +logical function fms_diag_fields_object_init(ob) + class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object + integer :: i !< For looping +#ifdef use_yaml + allocate(ob(get_num_unique_fields())) + registered_variables = 0 +#endif + do i = 1,size(ob) + ob%diag_id = diag_not_registered !null_ob%diag_id + ob%registered = .false. + enddo + module_is_initialized = .true. + fms_diag_fields_object_init = .true. +end function fms_diag_fields_object_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \Description Fills in and allocates (when necessary) the values in the diagnostic object subroutine fms_register_diag_field_obj & @@ -216,7 +194,7 @@ subroutine fms_register_diag_field_obj & longname, units, missing_value, varRange, mask_variant, standname, & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) - class(fmsDiagField_type), INTENT(inout) :: dobj !< Diaj_obj to fill + class(fmsDiagField_type), INTENT(inout) :: dobj !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: modname !< The module name CHARACTER(len=*), INTENT(in) :: varname !< The variable name integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index a0ba7d1bff..0e50bdff87 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -36,7 +36,8 @@ module fms_diag_file_object_mod implicit none private -public :: fmsDiagFile_type, FMS_diag_files, fms_diag_files_object_init, fms_diag_files_object_initialized +public :: fmsDiagFileContainer_type +public :: fmsDiagFile_type, fms_diag_files_object_init, fms_diag_files_object_initialized logical :: fms_diag_files_object_initialized = .false. @@ -122,21 +123,20 @@ module fms_diag_file_object_mod end type fmsDiagFile_type type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_files !< The array of diag files - +class(fmsDiagFileContainer_type),dimension (:), allocatable, target :: FMS_diag_files contains !< @brief Allocates the number of files and sets an ID based for each file !! @return true if there are files allocated in the YAML object -logical function fms_diag_files_object_init () +logical function fms_diag_files_object_init (FMS_diag_files) #ifdef use_yaml + class(fmsDiagFileContainer_type), allocatable, intent(out) :: obj (:) !< array of diag files integer :: nFiles !< Number of files in the diag yaml integer :: i !< Looping iterator - type(fmsDiagFile_type), pointer :: obj !< FMS_diag_files(i) (for less typing) if (diag_yaml%has_diag_files()) then nFiles = diag_yaml%size_diag_files() allocate (FMS_diag_files(nFiles)) set_ids_loop: do i= 1,nFiles - obj => FMS_diag_files(i) obj%diag_yaml_file => diag_yaml%diag_files(i) obj%id = i allocate(obj%var_ids(diag_yaml%diag_files(i)%size_file_varlist())) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index aa6e801d9d..684a6bb469 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -17,16 +17,29 @@ !* License along with FMS. If not, see . !*********************************************************************** module fms_diag_object_mod -use fms_diag_file_object_mod :: FMS_diag_files -use fms_diag_field_object_mod :: fmsDiagField_type +use fms_diag_file_object_mod :: fmsDiagFileContainer_type, fms_diag_files_object_init +use fms_diag_field_object_mod :: fmsDiagField_type, fms_diag_fields_object_init +use fms_diag_yaml_object_mod :: diag_yaml_object_init +use fms_diag_axis_object_mod :: fms_diag_axis_object_init +implicit none +private type fmsDiagObject_type !TODO add container arrays - TYPE(fmsDiagField_type), private, ALLOCATABLE, target :: diag_fields(:) !< Array of diag objects - !! one for each registered variable +private + class(fmsDiagFileContainer_type), allocatable, target :: FMS_diag_files (:) !< array of diag files + TYPE(fmsDiagField_type), ALLOCATABLE, target :: FMS_diag_fields(:) !< Array of diag fields integer, private :: registered_variables !< Number of registered variables + logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: files_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: fields_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: buffers_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: axes_initialized=.false. !< True if the fmsDiagObject is initialized + contains + procedure :: init => fms_diag_object_init procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. + procedure :: diag_end => fms_diag_object_end end type fmsDiagObject_type type (fmsDiagObject_type), target :: fms_diag_object @@ -37,6 +50,40 @@ module fms_diag_object_mod public :: fms_register_static_field public :: fms_diag_object contains +!> @brief Initiliazes the fms_diag_object. +!! Reads the diag_table.yaml and fills in the yaml object +!! Allocates the diag manager object arrays for files, fields, and buffers +!! Initializes variables +subroutine fms_diag_object_init (obj,diag_subset_output) + class(fmsDiagObject_type) :: obj + + if (obj%initialized) return +#ifdef use_yaml +!TODO: Read name list +!TODO: Read YAML +!TODO: allocate the file, field, and buffer containers +! allocate(diag_objs(get_num_unique_fields())) + CALL diag_yaml_object_init(diag_subset_output) + CALL fms_diag_axis_object_init() + obj%files_initialized = fms_diag_files_object_init (FMS_diag_files) + obj%fields_initialized = fms_diag_fields_object_init (FMS_diag_fields) + registered_variables = 0 +#else + !TODO: FATAL modern diag requires the use of yaml +#endif + obj%initialized = .true. +end subroutine fms_diag_object_init +!> \description Loops through all files and does one final write. +!! Closes all files +!! Deallocates all buffers, fields, and files +!! Uninitializes the fms_diag_object +subroutine fms_diag_object_end (obj) + class(fmsDiagObject_type) :: obj + !TODO: loop through files and force write + !TODO: Close all files + !TODO: Deallocate diag object arrays and clean up all memory + obj%initialized = .false. +end subroutine fms_diag_object_end !> \Description Fills in and allocates (when necessary) the values in the diagnostic object subroutine fms_register_diag_field_obj & !(field_obj, modname, varname, axes, time, longname, units, missing_value, metadata) From 412f0b3cd31e443641209b396ed46f30c6857e1d Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Thu, 11 Aug 2022 15:14:20 -0400 Subject: [PATCH 04/11] Fixes all dependencies for fms_diag_object. Diag_manager only needs fms_diag_object to do inits and registers --- diag_manager/diag_manager.F90 | 36 ++-- diag_manager/fms_diag_field_object.F90 | 251 +++-------------------- diag_manager/fms_diag_file_object.F90 | 120 +++++++---- diag_manager/fms_diag_object.F90 | 269 +++++++++++-------------- 4 files changed, 247 insertions(+), 429 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index a8ed7fc545..a2eafdb38e 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -236,14 +236,10 @@ MODULE diag_manager_mod USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end - USE fms_diag_field_object_mod, ONLY: fmsDiagField_type, fms_diag_object_init, fms_register_diag_field_array, & - & fms_register_diag_field_scalar, fms_diag_object_end, fms_register_static_field, fms_diag_field_add_attribute, & - & fms_get_diag_field_id - USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized #ifdef use_yaml use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field use fms_diag_axis_object_mod, only: fms_diag_axis_object_end, fms_diag_axis_object_init - use fms_diag_file_object_mod, only: fms_diag_files_object_init + use fms_diag_object_mod, only:fms_diag_object #endif USE constants_mod, ONLY: SECONDS_PER_DAY @@ -407,8 +403,9 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, END IF END IF if (use_modern_diag) then - register_diag_field_scalar = fms_register_diag_field_scalar(module_name, field_name, init_time, & - & long_name=long_name, units=units, missing_value=missing_value, var_range=range, standard_name=standard_name, & + register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( & + & module_name, field_name, init_time, long_name=long_name, units=units, & + & missing_value=missing_value, var_range=range, standard_name=standard_name, & & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm) else register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, & @@ -445,8 +442,9 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute if (use_modern_diag) then - register_diag_field_array = fms_register_diag_field_array(module_name, field_name, axes, init_time, & - & long_name=long_name, units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, & + register_diag_field_array = fms_diag_object%fms_register_diag_field_array( & + & module_name, field_name, axes, init_time, long_name=long_name, & + & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, & & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) else @@ -493,7 +491,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF if (use_modern_diag) then - register_static_field = fms_register_static_field(module_name, field_name, axes, & + register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,& & tile_count=tile_count, area=area, volume=volume, realm=realm) @@ -1228,7 +1226,7 @@ INTEGER FUNCTION get_diag_field_id(module_name, field_name) get_diag_field_id = DIAG_FIELD_NOT_FOUND if (use_modern_diag) then - get_diag_field_id = fms_get_diag_field_id(module_name, field_name) + get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name) else ! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not ! included in the diag_table @@ -3704,7 +3702,7 @@ SUBROUTINE diag_manager_end(time) if (use_modern_diag) then call diag_yaml_object_end call fms_diag_axis_object_end() - call fms_diag_object_end() + call fms_diag_object%diag_end() endif #endif END SUBROUTINE diag_manager_end @@ -3922,9 +3920,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) if (use_modern_diag) then CALL diag_yaml_object_init(diag_subset_output) CALL fms_diag_axis_object_init() - CALL fms_diag_object_init(255, 255) !< TO DO: MAX_LEN_VARNAME and MAX_LEN_META are supposed to be read from - !! the namelist and sent to fms_diag_object - fms_diag_files_object_initialized = fms_diag_files_object_init () + CALL fms_diag_object%init(diag_subset_output) endif #else if (use_modern_diag) & @@ -4220,7 +4216,7 @@ SUBROUTINE diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) REAL, INTENT(in) :: att_value !< new attribute value if (use_modern_diag) then - call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) else CALL diag_field_add_attribute_r1d(diag_field_id, att_name, (/ att_value /)) endif @@ -4233,7 +4229,7 @@ SUBROUTINE diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) INTEGER, INTENT(in) :: att_value !< new attribute value if (use_modern_diag) then - call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) else CALL diag_field_add_attribute_i1d(diag_field_id, att_name, (/ att_value /)) endif @@ -4246,7 +4242,7 @@ SUBROUTINE diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_value !< new attribute value if (use_modern_diag) then - call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /)) else CALL diag_field_attribute_init(diag_field_id, att_name, NF90_CHAR, cval=att_value) endif @@ -4259,7 +4255,7 @@ SUBROUTINE diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) REAL, DIMENSION(:), INTENT(in) :: att_value !< new attribute value if (use_modern_diag) then - call fms_diag_field_add_attribute(diag_field_id, att_name, att_value) + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value) else CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value) endif @@ -4272,7 +4268,7 @@ SUBROUTINE diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) INTEGER, DIMENSION(:), INTENT(in) :: att_value !< new attribute value if (use_modern_diag) then - call fms_diag_field_add_attribute(diag_field_id, att_name, att_value) + call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value) else CALL diag_field_attribute_init(diag_field_id, att_name, NF90_INT, ival=att_value) endif diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index 441456683e..5b4c1b96a8 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -62,7 +62,7 @@ module fms_diag_field_object_mod integer, allocatable, dimension(:), private :: output_units integer, allocatable, private :: t integer, allocatable, private :: tile_count !< The number of tiles - integer, pointer, dimension(:), private :: axis_ids !< variable axis IDs + integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs class(diagDomain_t), pointer, private :: domain !< Domain INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", !! "TWO_D_DOMAIN", or "UG_DOMAIN") @@ -71,17 +71,19 @@ module fms_diag_field_object_mod class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data contains ! procedure :: send_data => fms_send_data !!TODO - procedure :: init_ob => fms_diag_fields_object_init +! Get ID functions procedure :: get_id => fms_diag_get_id procedure :: id => fms_diag_get_id + procedure :: id_from_name => diag_field_id_from_name procedure :: copy => copy_diag_obj procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. procedure :: setID => set_diag_id procedure :: set_type => set_vartype + procedure :: add_attribute => diag_field_add_attribute procedure :: vartype_inq => what_is_vartype ! Check functions procedure :: is_static => diag_obj_is_static - procedure :: is_registered => diag_ob_registered + procedure :: is_registered => get_registered procedure :: is_registeredB => diag_obj_is_registered procedure :: is_mask_variant => get_mask_variant procedure :: is_local => get_local @@ -148,14 +150,7 @@ module fms_diag_field_object_mod public :: fms_diag_fields_object_init public :: null_ob public :: copy_diag_obj, fms_diag_get_id -public :: fms_diag_object_init -public :: fms_diag_object_end -public :: fms_register_diag_field_array -public :: fms_register_diag_field_scalar -public :: fms_register_static_field -public :: fms_diag_field_add_attribute -public :: get_diag_obj_from_id -public :: fms_get_diag_field_id +public :: fms_diag_field_object_end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CONTAINS @@ -163,11 +158,11 @@ module fms_diag_field_object_mod !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> @brief Deallocates the array of diag_objs -subroutine fms_diag_object_end (ob) +subroutine fms_diag_field_object_end (ob) class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object if (allocated(ob)) deallocate(ob) module_is_initialized = .false. -end subroutine fms_diag_object_end +end subroutine fms_diag_field_object_end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \Description Allocates the diad field object array. !! Sets the diag_id to the not registered value. @@ -180,8 +175,8 @@ logical function fms_diag_fields_object_init(ob) registered_variables = 0 #endif do i = 1,size(ob) - ob%diag_id = diag_not_registered !null_ob%diag_id - ob%registered = .false. + ob(i)%diag_id = diag_not_registered !null_ob%diag_id + ob(i)%registered = .false. enddo module_is_initialized = .true. fms_diag_fields_object_init = .true. @@ -192,7 +187,7 @@ subroutine fms_register_diag_field_obj & !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata) (dobj, modname, varname, diag_field_indices, axes, init_time, & longname, units, missing_value, varRange, mask_variant, standname, & - do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static) class(fmsDiagField_type), INTENT(inout) :: dobj !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: modname !< The module name @@ -218,6 +213,7 @@ subroutine fms_register_diag_field_obj & INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the !! modeling_realm attribute + LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field integer :: i !< For do loops integer :: j !< dobj%file_ids(i) (for less typing :) @@ -226,22 +222,10 @@ subroutine fms_register_diag_field_obj & !> Fill in information from the register call dobj%varname = trim(varname) dobj%modname = trim(modname) - -!> Fill in diag_field and find the ids of the files that this variable is in - dobj%diag_field = get_diag_fields_entries(diag_field_indices) - dobj%file_ids = get_diag_files_id(diag_field_indices) - +!> Add axis and domain information if (present(axes)) then - dobj%axis_ids => axes + dobj%axis_ids = axes call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname) - do i = 1, size(dobj%file_ids) - j = dobj%file_ids(i) - call FMS_diag_files(j)%set_file_domain(dobj%domain, dobj%type_of_domain) - call FMS_diag_files(j)%add_axes(axes) - if (present(init_time)) call FMS_diag_files(j)%add_start_time(init_time) - enddo - !> TO DO: - !! Mark the field as registered in the diag_files else !> The variable is a scalar dobj%type_of_domain = NO_DOMAIN @@ -258,6 +242,11 @@ subroutine fms_register_diag_field_obj & allocate(dobj%tile_count) dobj%tile_count = tile_count endif + if (present(static)) then + dobj%static = static + else + dobj%static = .false. + endif if (present(missing_value)) then select type (missing_value) @@ -414,14 +403,6 @@ subroutine what_is_vartype(objin) end select end subroutine what_is_vartype !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!MZ Is this a TODO. Many problems: -!> \brief Registers the object -subroutine diag_ob_registered(objin , reg) - class (fmsDiagField_type) , intent(inout):: objin - logical , intent(in) :: reg !< If registering, this is true - objin%registered = reg -end subroutine diag_ob_registered -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief Copies the calling object into the object that is the argument of the subroutine subroutine copy_diag_obj(objin , objout) class (fmsDiagField_type) , intent(in) :: objin @@ -445,9 +426,8 @@ end subroutine copy_diag_obj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief Returns the ID integer for a variable !! \return the diag ID -integer function fms_diag_get_id (dobj) result(diag_id) - class(fmsDiagField_type) , intent(inout) :: dobj -! character(*) , intent(in) :: varname +pure integer function fms_diag_get_id (dobj) result(diag_id) + class(fmsDiagField_type) , intent(in) :: dobj !> Check if the diag_object registration has been done if (allocated(dobj%registered)) then !> Return the diag_id if the variable has been registered @@ -951,204 +931,35 @@ pure logical function has_data_RANGE (obj) has_data_RANGE = allocated(obj%data_RANGE) end function has_data_RANGE - !> @brief Registers a scalar field - !! @return field index for subsequent call to send_data. - INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_time, & - & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,& - & area, volume, realm) - CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from - CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field - TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute - CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute - CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file - CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute - CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged - CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call - INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field - INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field - CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute - -#ifdef use_yaml - integer, allocatable :: diag_field_indices(:) !< indices where the field was found - - diag_field_indices = find_diag_field(field_name, module_name) - if (diag_field_indices(1) .eq. diag_null) then - !< The field was not found in the table, so return diag_null - fms_register_diag_field_scalar = diag_null - deallocate(diag_field_indices) - return - endif - - registered_variables = registered_variables + 1 - fms_register_diag_field_scalar = registered_variables - - call diag_objs(registered_variables)%setID(registered_variables) - call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, & - & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & - & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & - & area=area, volume=volume, realm=realm) - deallocate(diag_field_indices) -#endif - - end function fms_register_diag_field_scalar - - !> @brief Registers an array field - !> @return field index for subsequent call to send_data. - INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, init_time, & - & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,& - & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) - CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from - CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field - INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis - TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute - CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute - CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute - CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute - LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant - CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file - LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged - CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call - CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when - !! regridding the field in post-processing. - !! Valid options are "conserve_order1", - !! "conserve_order2", and "none". - INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number - INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field - INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field - CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute - -#ifdef use_yaml - integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found - - diag_field_indices = find_diag_field(field_name, module_name) - if (diag_field_indices(1) .eq. diag_null) then - !< The field was not found in the table, so return diag_null - fms_register_diag_field_array = diag_null - deallocate(diag_field_indices) - return - endif - - registered_variables = registered_variables + 1 - fms_register_diag_field_array = registered_variables - - call diag_objs(registered_variables)%setID(registered_variables) - call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, & - & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & - & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & - & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) - deallocate(diag_field_indices) -#endif - -end function fms_register_diag_field_array - -!> @brief Return field index for subsequent call to send_data. -!! @return field index for subsequent call to send_data. -INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_name, units,& - & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& - & tile_count, area, volume, realm) - CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on - CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field - INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute - CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute - CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute - CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute - CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to be added as a attribute - LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has - !! a mask variant - LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged - CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when - !! regridding the field in post-processing - !! Valid options are "conserve_order1", - !! "conserve_order2", and "none". - INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles - INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated - !! with this field - INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated - !! with this field - CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the - !! modeling_realm attribute - -#ifdef use_yaml - integer, allocatable :: diag_field_indices(:) !< indices where the field was foun - - diag_field_indices = find_diag_field(field_name, module_name) - if (diag_field_indices(1) .eq. diag_null) then - !< The field was not found in the table, so return diag_null - fms_register_static_field = diag_null - deallocate(diag_field_indices) - return - endif - - registered_variables = registered_variables + 1 - fms_register_static_field = registered_variables - - call diag_objs(registered_variables)%setID(registered_variables) - allocate(diag_objs(registered_variables)%static) - diag_objs(registered_variables)%static = .true. - call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, axes=axes, & - & longname=long_name, units=units, missing_value=missing_value, varrange=range, & - & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm) - deallocate(diag_field_indices) -#endif -end function fms_register_static_field - -!> @brief Get a pointer to the diag_object from the id. -!> @return A pointer to the diag_object or a null pointer if the id is not valid -FUNCTION get_diag_obj_from_id ( id ) result (obj_ptr) - integer :: id !< Id of the diag_obj to get - class(fmsDiagField_type), pointer :: obj_ptr - - obj_ptr => null() - IF (id >= 1 .and. id <= registered_variables) THEN - obj_ptr => diag_objs(id) - END IF -END FUNCTION get_diag_obj_from_id - !> @brief Add a attribute to the diag_obj using the diag_field_id -subroutine fms_diag_field_add_attribute(diag_field_id, att_name, att_value) - integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to +subroutine diag_field_add_attribute(obj, att_name, att_value) + class (fmsDiagField_type), intent (inout) :: obj !< The field object character(len=*), intent(in) :: att_name !< Name of the attribute class(*), intent(in) :: att_value(:) !< The attribute value to add - type(fmsDiagField_type), pointer :: obj - - obj => get_diag_obj_from_id ( diag_field_id ) - if (.not. associated(obj)) return - obj%num_attributes = obj%num_attributes + 1 if (obj%num_attributes > max_field_attributes) & call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"& //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.") call obj%attributes(obj%num_attributes)%add(att_name, att_value) - nullify(obj) -end subroutine fms_diag_field_add_attribute +end subroutine diag_field_add_attribute !> @brief Determines the diag_obj id corresponding to a module name and field_name !> @return diag_obj id -PURE FUNCTION fms_get_diag_field_id(module_name, field_name) & +PURE FUNCTION diag_field_id_from_name(diag_objs, module_name, field_name) & result(diag_field_id) - + CLASS(fmsDiagField_type), INTENT(in) :: diag_objs !< The field object CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable CHARACTER(len=*), INTENT(in) :: field_name !< Variable name integer :: diag_field_id - integer :: i !< For do loops diag_field_id = DIAG_FIELD_NOT_FOUND - do i = 1, registered_variables - if (diag_objs(i)%get_varname() .eq. trim(field_name) .and. & - diag_objs(i)%get_modname() .eq. trim(module_name)) then - diag_field_id = i - return - endif - enddo -end function fms_get_diag_field_id + if (diag_objs%get_varname() .eq. trim(field_name) .and. & + diag_objs%get_modname() .eq. trim(module_name)) then + diag_field_id = diag_objs%get_id() + endif +end function diag_field_id_from_name end module fms_diag_field_object_mod diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 0e50bdff87..7b260c10bf 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -25,13 +25,13 @@ !! list of the variables and their variable IDs that are in the file. module fms_diag_file_object_mod use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t -use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time +use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED use diag_util_mod, only: diag_time_inc use time_manager_mod, only: time_type, operator(/=), operator(==) #ifdef use_yaml use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type #endif -use fms_diag_axis_object_mod, only: diagDomain_t +use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type use mpp_mod, only: mpp_error, FATAL implicit none private @@ -63,32 +63,30 @@ module fms_diag_file_object_mod !! null if NO_DOMAIN or SUB_REGIONAL character(len=:) , dimension(:), allocatable :: file_metadata_from_model !< File metadata that comes from !! the model. - integer, dimension(:), allocatable :: var_ids !< Variable IDs corresponding to file_varlist - integer, dimension(:), private, allocatable :: var_index !< An array of the variable indicies in the - !! diag_object. This should be the same size as - !! `file_varlist` - logical, dimension(:), private, allocatable :: var_reg !< Array corresponding to `file_varlist`, .true. + integer, dimension(:), allocatable :: field_ids !< Variable IDs corresponding to file_varlist + logical, dimension(:), private, allocatable :: field_registered !< Array corresponding to `field_ids`, .true. !! if the variable has been registered and - !! `file_var_index` has been set for the variable + !! `field_id` has been set for the variable integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file - integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file integer :: number_of_axis !< Number of axis in the file contains + procedure, public :: add_field_id procedure, public :: has_file_metadata_from_model procedure, public :: has_fileobj #ifdef use_yaml procedure, public :: has_diag_yaml_file + procedure, public :: set_domain_from_axis procedure, public :: set_file_domain procedure, public :: add_axes procedure, public :: add_start_time #endif - procedure, public :: has_var_ids + procedure, public :: has_field_ids procedure, public :: get_id ! TODO procedure, public :: get_fileobj ! TODO ! TODO procedure, public :: get_diag_yaml_file ! TODO procedure, public :: get_file_metadata_from_model - procedure, public :: get_var_ids + procedure, public :: get_field_ids ! The following fuctions come will use the yaml inquiry functions #ifdef use_yaml procedure, public :: get_file_fname @@ -121,31 +119,54 @@ module fms_diag_file_object_mod #endif end type fmsDiagFile_type +type, extends (fmsDiagFile_type) :: subRegionalFile_type + integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file +end type subRegionalFile_type + +!> \brief A container for fmsDiagFile_type. This is used to create the array of files +type fmsDiagFileContainer_type + class (fmsDiagFile_type),allocatable :: FMS_diag_file !< The individual file object +end type fmsDiagFileContainer_type -type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_files !< The array of diag files -class(fmsDiagFileContainer_type),dimension (:), allocatable, target :: FMS_diag_files +!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files +!class(fmsDiagFileContainer_type),dimension (:), allocatable, target :: FMS_diag_file contains !< @brief Allocates the number of files and sets an ID based for each file !! @return true if there are files allocated in the YAML object -logical function fms_diag_files_object_init (FMS_diag_files) +logical function fms_diag_files_object_init (files_array) #ifdef use_yaml - class(fmsDiagFileContainer_type), allocatable, intent(out) :: obj (:) !< array of diag files + class(fmsDiagFileContainer_type), allocatable, target, intent(inout) :: files_array (:) !< array of diag files + class(fmsDiagFile_type), pointer :: obj => null() !< Pointer for each member of the array integer :: nFiles !< Number of files in the diag yaml integer :: i !< Looping iterator if (diag_yaml%has_diag_files()) then nFiles = diag_yaml%size_diag_files() - allocate (FMS_diag_files(nFiles)) + allocate (files_array(nFiles)) set_ids_loop: do i= 1,nFiles + !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array. + !! This will be set in a add_axes + if (files_array(i)%FMS_diag_file%has_file_sub_region()) then + allocate(subRegionalFile_type :: files_array(i)%FMS_diag_file) + obj => files_array(i)%FMS_diag_file + obj%type_of_domain = SUB_REGIONAL + select type (obj) + type is (subRegionalFile_type) + allocate(obj%sub_axis_ids(max_axes)) + obj%sub_axis_ids = diag_null + end select + else + allocate(FmsDiagFile_type::files_array(i)%FMS_diag_file) + obj => files_array(i)%FMS_diag_file + endif + !! obj%diag_yaml_file => diag_yaml%diag_files(i) obj%id = i - allocate(obj%var_ids(diag_yaml%diag_files(i)%size_file_varlist())) - allocate(obj%var_index(diag_yaml%diag_files(i)%size_file_varlist())) - allocate(obj%var_reg(diag_yaml%diag_files(i)%size_file_varlist())) + allocate(obj%field_ids(diag_yaml%diag_files(i)%size_file_varlist())) + allocate(obj%field_registered(diag_yaml%diag_files(i)%size_file_varlist())) !! Initialize the integer arrays - obj%var_ids = DIAG_NULL - obj%var_reg = .FALSE. - obj%var_index = DIAG_NULL + obj%field_ids = DIAG_NOT_REGISTERED + obj%field_registered = .FALSE. !> These will be set in a set_file_domain obj%type_of_domain = NO_DOMAIN @@ -153,15 +174,6 @@ logical function fms_diag_files_object_init (FMS_diag_files) !> This will be set in a add_axes allocate(obj%axis_ids(max_axes)) - - !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array. - !! This will be set in a add_axes - if (obj%has_file_sub_region()) then - obj%type_of_domain = SUB_REGIONAL - allocate(obj%sub_axis_ids(max_axes)) - obj%sub_axis_ids = diag_null - endif - obj%number_of_axis = 0 !> Set the start_time of the file to the base_time and set up the *_output variables @@ -183,6 +195,23 @@ logical function fms_diag_files_object_init (FMS_diag_files) fms_diag_files_object_init = .false. #endif end function fms_diag_files_object_init +!> \brief Adds a field ID to the file +subroutine add_field_id (obj, new_field_id) + class(fmsDiagFile_type), intent(inout) :: obj !< The file object + integer, intent(in) :: new_field_id !< The field ID to be added to field_ids + integer :: i !< For looping + do i = 1, size(obj%field_ids) + if (.not.obj%field_registered(i)) then + obj%field_ids(i) = new_field_id + obj%field_registered(i) = .true. + return + endif + enddo + + call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has already been assigned its maximum "//& + "number of fields.") +end subroutine add_field_id + !> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated !! \return .True. if file_metadata_from_model exists .False. if file_metadata_from_model has not been set pure logical function has_file_metadata_from_model (obj) @@ -203,12 +232,12 @@ pure logical function has_diag_yaml_file (obj) has_diag_yaml_file = associated(obj%diag_yaml_file) end function has_diag_yaml_file #endif -!> \brief Logical function to determine if the variable var_ids has been allocated or associated -!! \return .True. if var_ids exists .False. if var_ids has not been set -pure logical function has_var_ids (obj) +!> \brief Logical function to determine if the variable field_ids has been allocated or associated +!! \return .True. if field_ids exists .False. if field_ids has not been set +pure logical function has_field_ids (obj) class(fmsDiagFile_type), intent(in) :: obj !< The file object - has_var_ids = allocated(obj%var_ids) -end function has_var_ids + has_field_ids = allocated(obj%field_ids) +end function has_field_ids !> \brief Returns a copy of the value of id !! \return A copy of id pure function get_id (obj) result (res) @@ -243,14 +272,14 @@ pure function get_file_metadata_from_model (obj) result (res) character(len=:), dimension(:), allocatable :: res res = obj%file_metadata_from_model end function get_file_metadata_from_model -!> \brief Returns a copy of the value of var_ids -!! \return A copy of var_ids -pure function get_var_ids (obj) result (res) +!> \brief Returns a copy of the value of field_ids +!! \return A copy of field_ids +pure function get_field_ids (obj) result (res) class(fmsDiagFile_type), intent(in) :: obj !< The file object integer, dimension(:), allocatable :: res - allocate(res(size(obj%var_ids))) - res = obj%var_ids -end function get_var_ids + allocate(res(size(obj%field_ids))) + res = obj%field_ids +end function get_field_ids !!!!!!!!! Functions from diag_yaml_file #ifdef use_yaml !> \brief Returns a copy of file_fname from the yaml object @@ -436,7 +465,12 @@ pure function has_file_global_meta (obj) result(res) logical :: res res = obj%diag_yaml_file%has_file_global_meta() end function has_file_global_meta - +!> @brief Sets the domain and type of domain from the axis IDs +subroutine set_domain_from_axis(obj, axes) + class(fmsDiagFile_type), intent(inout) :: obj !< The file object + integer, intent(in) :: axes (:) + call get_domain_and_domain_type(axes, obj%type_of_domain, obj%domain, obj%get_file_fname()) +end subroutine set_domain_from_axis !> @brief Set the domain and the type_of_domain for a file !> @details This subroutine is going to be called once by every variable in the file !! in register_diag_field. It will update the domain and the type_of_domain if needed and verify that diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 684a6bb469..4e2b4ddb4a 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -17,18 +17,24 @@ !* License along with FMS. If not, see . !*********************************************************************** module fms_diag_object_mod -use fms_diag_file_object_mod :: fmsDiagFileContainer_type, fms_diag_files_object_init -use fms_diag_field_object_mod :: fmsDiagField_type, fms_diag_fields_object_init -use fms_diag_yaml_object_mod :: diag_yaml_object_init -use fms_diag_axis_object_mod :: fms_diag_axis_object_init +use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init +use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init +use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id +use fms_diag_axis_object_mod, only: fms_diag_axis_object_init +use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & + &DIAG_FIELD_NOT_FOUND + USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& + & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & + & get_ticks_per_second + implicit none private type fmsDiagObject_type !TODO add container arrays private - class(fmsDiagFileContainer_type), allocatable, target :: FMS_diag_files (:) !< array of diag files - TYPE(fmsDiagField_type), ALLOCATABLE, target :: FMS_diag_fields(:) !< Array of diag fields + class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files + class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields integer, private :: registered_variables !< Number of registered variables logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized logical, private :: files_initialized=.false. !< True if the fmsDiagObject is initialized @@ -38,24 +44,36 @@ module fms_diag_object_mod contains procedure :: init => fms_diag_object_init + procedure :: fms_register_diag_field_scalar + procedure :: fms_register_diag_field_array + procedure :: fms_register_static_field procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. + procedure :: fms_diag_field_add_attribute + procedure :: fms_get_diag_field_id_from_name procedure :: diag_end => fms_diag_object_end end type fmsDiagObject_type type (fmsDiagObject_type), target :: fms_diag_object +integer, private :: registered_variables !< Number of registered variables public :: fms_register_diag_field_obj public :: fms_register_diag_field_scalar public :: fms_register_diag_field_array public :: fms_register_static_field +public :: fms_diag_field_add_attribute +public :: fms_get_diag_field_id_from_name public :: fms_diag_object +public :: fmsDiagObject_type + contains + !> @brief Initiliazes the fms_diag_object. !! Reads the diag_table.yaml and fills in the yaml object !! Allocates the diag manager object arrays for files, fields, and buffers !! Initializes variables subroutine fms_diag_object_init (obj,diag_subset_output) - class(fmsDiagObject_type) :: obj + class(fmsDiagObject_type) :: obj !< Diag mediator/controller object + integer :: diag_subset_output !< Subset of the diag output? if (obj%initialized) return #ifdef use_yaml @@ -65,8 +83,8 @@ subroutine fms_diag_object_init (obj,diag_subset_output) ! allocate(diag_objs(get_num_unique_fields())) CALL diag_yaml_object_init(diag_subset_output) CALL fms_diag_axis_object_init() - obj%files_initialized = fms_diag_files_object_init (FMS_diag_files) - obj%fields_initialized = fms_diag_fields_object_init (FMS_diag_fields) + obj%files_initialized = fms_diag_files_object_init(obj%FMS_diag_files) + obj%fields_initialized = fms_diag_fields_object_init (obj%FMS_diag_fields) registered_variables = 0 #else !TODO: FATAL modern diag requires the use of yaml @@ -91,7 +109,7 @@ subroutine fms_register_diag_field_obj & longname, units, missing_value, varRange, mask_variant, standname, & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) - class(fmsDiagObject_type), INTENT(inout) :: fms_diag_object !< Diaj_obj to fill + class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: modname !< The module name CHARACTER(len=*), INTENT(in) :: varname !< The variable name integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field @@ -116,141 +134,64 @@ subroutine fms_register_diag_field_obj & CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the !! modeling_realm attribute + class (fmsDiagFile_type), pointer :: fileptr => null() + class (fmsDiagField_type), pointer :: fieldptr => null() + integer, allocatable :: file_ids(:) !< The file IDs for this variable integer :: i !< For do loops - integer :: j !< fms_diag_object%field_obj%file_ids(i) (for less typing :) - + integer :: j !< fms_diag_object%FMS_diag_fields%file_ids(i) (for less typing :) + #ifdef use_yaml -!> Fill in information from the register call - fms_diag_object%field_obj%varname = trim(varname) - fms_diag_object%field_obj%modname = trim(modname) - -!> Fill in diag_field and find the ids of the files that this variable is in - fms_diag_object%field_obj%diag_field = get_diag_fields_entries(diag_field_indices) - fms_diag_object%field_obj%file_ids = get_diag_files_id(diag_field_indices) - - if (present(axes)) then - fms_diag_object%field_obj%axis_ids => axes - call get_domain_and_domain_type(fms_diag_object%field_obj%axis_ids, fms_diag_object%field_obj%type_of_domain, fms_diag_object%field_obj%domain, fms_diag_object%field_obj%varname) - do i = 1, size(fms_diag_object%field_obj%file_ids) - j = fms_diag_object%field_obj%file_ids(i) - call FMS_diag_files(j)%set_file_domain(fms_diag_object%field_obj%domain, fms_diag_object%field_obj%type_of_domain) - call FMS_diag_files(j)%add_axes(axes) - if (present(init_time)) call FMS_diag_files(j)%add_start_time(init_time) +!> Use pointers for convenience + fieldptr => fms_diag_object%FMS_diag_fields(registered_variables) +!> Register the data for the field + call fieldptr%register(modname, varname, diag_field_indices, & + axes, init_time, longname, units, missing_value, varRange, mask_variant, standname, & + do_not_log, err_msg, interp_method, tile_count, area, volume, realm) +!> Get the file IDs from the field indicies from the yaml + file_ids = get_diag_files_id(diag_field_indices) +!> Add the axis information, initial time, and field IDs to the files + if (present(axes) .and. present(init_time)) then + do i = 1, size(file_ids) + fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_id(fieldptr%get_id()) + call fileptr%set_domain_from_axis(axes) + call fileptr%add_axes(axes) + call fileptr%add_start_time(init_time) + enddo + elseif (present(axes)) then !only axes present + do i = 1, size(file_ids) + fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_id(fieldptr%get_id()) + call fileptr%set_domain_from_axis(axes) + call fileptr%add_axes(axes) + enddo + elseif (present(init_time)) then !only inti time present + do i = 1, size(file_ids) + fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_id(fieldptr%get_id()) + call fileptr%add_start_time(init_time) + enddo + else !no axis or init time present + do i = 1, size(file_ids) + fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file + call fileptr%add_field_id(fieldptr%get_id()) enddo - !> TO DO: - !! Mark the field as registered in the diag_files - else - !> The variable is a scalar - fms_diag_object%field_obj%type_of_domain = NO_DOMAIN - fms_diag_object%field_obj%domain => null() - endif - -!> get the optional arguments if included and the diagnostic is in the diag table - if (present(longname)) fms_diag_object%field_obj%longname = trim(longname) - if (present(standname)) fms_diag_object%field_obj%standname = trim(standname) - if (present(units)) fms_diag_object%field_obj%units = trim(units) - if (present(realm)) fms_diag_object%field_obj%realm = trim(realm) - if (present(interp_method)) fms_diag_object%field_obj%interp_method = trim(interp_method) - if (present(tile_count)) then - allocate(fms_diag_object%field_obj%tile_count) - fms_diag_object%field_obj%tile_count = tile_count - endif - - if (present(missing_value)) then - select type (missing_value) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: fms_diag_object%field_obj%missing_value) - fms_diag_object%field_obj%missing_value = missing_value - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: fms_diag_object%field_obj%missing_value) - fms_diag_object%field_obj%missing_value = missing_value - type is (real(kind=r4_kind)) - allocate(integer(kind=r4_kind) :: fms_diag_object%field_obj%missing_value) - fms_diag_object%field_obj%missing_value = missing_value - type is (real(kind=r8_kind)) - allocate(integer(kind=r8_kind) :: fms_diag_object%field_obj%missing_value) - fms_diag_object%field_obj%missing_value = missing_value - class default - call mpp_error("fms_register_diag_field_obj", & - "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",& - FATAL) - end select - else - allocate(real :: fms_diag_object%field_obj%missing_value) - select type (miss => fms_diag_object%field_obj%missing_value) - type is (real) - miss = real(CMOR_MISSING_VALUE) - end select - endif - - if (present(varRANGE)) then - select type (varRANGE) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: fms_diag_object%field_obj%data_RANGE(2)) - fms_diag_object%field_obj%data_RANGE = varRANGE - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: fms_diag_object%field_obj%data_RANGE(2)) - fms_diag_object%field_obj%data_RANGE = varRANGE - type is (real(kind=r4_kind)) - allocate(integer(kind=r4_kind) :: fms_diag_object%field_obj%data_RANGE(2)) - fms_diag_object%field_obj%data_RANGE = varRANGE - type is (real(kind=r8_kind)) - allocate(integer(kind=r8_kind) :: fms_diag_object%field_obj%data_RANGE(2)) - fms_diag_object%field_obj%data_RANGE = varRANGE - class default - call mpp_error("fms_register_diag_field_obj", & - "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",& - FATAL) - end select - else - allocate(real :: fms_diag_object%field_obj%data_RANGE(2)) - select type (varRANGE => fms_diag_object%field_obj%data_RANGE) - type is (real) - varRANGE = real(CMOR_MISSING_VALUE) - end select - endif - - if (present(area)) then - if (area < 0) call mpp_error("fms_register_diag_field_obj", & - "The area id passed with field_name"//trim(varname)//" has not been registered."& - "Check that there is a register_diag_field call for the AREA measure and that is in the"& - "diag_table.yaml", FATAL) - allocate(fms_diag_object%field_obj%area) - fms_diag_object%field_obj%area = area - endif - - if (present(volume)) then - if (volume < 0) call mpp_error("fms_register_diag_field_obj", & - "The volume id passed with field_name"//trim(varname)//" has not been registered."& - "Check that there is a register_diag_field call for the VOLUME measure and that is in the"& - "diag_table.yaml", FATAL) - allocate(fms_diag_object%field_obj%volume) - fms_diag_object%field_obj%volume = volume - endif - - if (present(mask_variant)) then - allocate(fms_diag_object%field_obj%mask_variant) - fms_diag_object%field_obj%mask_variant = mask_variant - endif - - if (present(do_not_log)) then - allocate(fms_diag_object%field_obj%do_not_log) - fms_diag_object%field_obj%do_not_log = do_not_log endif + nullify (fileptr) + nullify (fieldptr) + !TODO: + !! Mark the field as registered in the diag_files + !! DO we actually need this? - !< Allocate space for any additional variable attributes - !< These will be fill out when calling `diag_field_add_attribute` - allocate(fms_diag_object%field_obj%attributes(max_field_attributes)) - fms_diag_object%field_obj%num_attributes = 0 - fms_diag_object%field_obj%registered = .true. #endif end subroutine fms_register_diag_field_obj !> @brief Registers a scalar field !! @return field index for subsequent call to send_data. - INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_time, & +INTEGER FUNCTION fms_register_diag_field_scalar(fms_diag_object,module_name, field_name, init_time, & & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,& & area, volume, realm) + class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from @@ -279,21 +220,23 @@ INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_ti registered_variables = registered_variables + 1 fms_register_diag_field_scalar = registered_variables - call diag_objs(registered_variables)%setID(registered_variables) - call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, & + call fms_diag_object%FMS_diag_fields(registered_variables)%setID(registered_variables) + call fms_diag_object%FMS_diag_fields(registered_variables)%register(& + & module_name, field_name, diag_field_indices, init_time=init_time, & & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & area=area, volume=volume, realm=realm) deallocate(diag_field_indices) #endif - end function fms_register_diag_field_scalar +end function fms_register_diag_field_scalar !> @brief Registers an array field !> @return field index for subsequent call to send_data. - INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, init_time, & +INTEGER FUNCTION fms_register_diag_field_array(fms_diag_object, module_name, field_name, axes, init_time, & & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,& & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis @@ -330,8 +273,9 @@ INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, in registered_variables = registered_variables + 1 fms_register_diag_field_array = registered_variables - call diag_objs(registered_variables)%setID(registered_variables) - call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, & + call fms_diag_object%FMS_diag_fields(registered_variables)%setID (registered_variables) + call fms_diag_object%FMS_diag_fields(registered_variables)%register( & + & module_name, field_name, diag_field_indices, init_time=init_time, & & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) @@ -342,9 +286,10 @@ end function fms_register_diag_field_array !> @brief Return field index for subsequent call to send_data. !! @return field index for subsequent call to send_data. -INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_name, units,& +INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_name, axes, long_name, units,& & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& & tile_count, area, volume, realm) + class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field @@ -383,15 +328,47 @@ INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_n registered_variables = registered_variables + 1 fms_register_static_field = registered_variables - call diag_objs(registered_variables)%setID(registered_variables) - allocate(diag_objs(registered_variables)%static) - diag_objs(registered_variables)%static = .true. - call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, axes=axes, & + call fms_diag_object%FMS_diag_fields(registered_variables)%setID(registered_variables) +! Include static as optional variable to register here + call fms_diag_object%FMS_diag_fields(registered_variables)%register( & + & module_name, field_name, diag_field_indices, axes=axes, & & longname=long_name, units=units, missing_value=missing_value, varrange=range, & - & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm) + & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, & + & static=.true.) deallocate(diag_field_indices) #endif end function fms_register_static_field +!> @brief Add a attribute to the diag_obj using the diag_field_id +subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name, att_value) + class(fmsDiagObject_type), intent (inout) :: fms_diag_object !< The diag object + integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add -end fms_diag_object_mod + if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) then + call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value) + else + !TODO: add error call + endif +end subroutine fms_diag_field_add_attribute +!> \brief Gets the diag field ID from the module name and field name. +!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered +PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) & + result(diag_field_id) + class(fmsDiagObject_type), intent (in) :: fms_diag_object !< The diag object + CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable + CHARACTER(len=*), INTENT(in) :: field_name !< Variable name + integer :: diag_field_id + integer :: i !< For looping +!> Initialize to not found + diag_field_id = DIAG_FIELD_NOT_FOUND +!> Loop through fields to find it. + if (registered_variables < 1) return + do i=1,registered_variables + diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name) + if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return + enddo +END FUNCTION fms_get_diag_field_id_from_name + +end module fms_diag_object_mod From 7c2d3dc0667d74a1b351590d43e52837954618b0 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Thu, 11 Aug 2022 15:36:58 -0400 Subject: [PATCH 05/11] Adds initialized check to diag yaml --- diag_manager/fms_diag_yaml.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 19c4c67a97..8f32e3b33d 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -116,7 +116,6 @@ module fms_diag_yaml_mod !! and values(dim=2) to be !! added as global meta data to !! the file - contains !> All getter functions (functions named get_x(), for member field named x) @@ -228,6 +227,9 @@ module fms_diag_yaml_mod type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml type (fileList_type), save :: file_list !< List of all files in the diag_table.yaml +logical, private :: diag_yaml_module_initialized = .false. + + !> @addtogroup fms_diag_yaml_mod !> @{ contains @@ -316,6 +318,8 @@ subroutine diag_yaml_object_init(diag_subset_output) logical :: write_file !< Flag indicating if the user wants the file to be written logical :: write_var !< Flag indicating if the user wants the variable to be written + if (diag_yaml_module_initialized) return + diag_yaml_id = open_and_parse_file("diag_table.yaml") call diag_get_value_from_key(diag_yaml_id, 0, "title", diag_yaml%diag_title) @@ -415,6 +419,7 @@ subroutine diag_yaml_object_init(diag_subset_output) call fms_sort_this(variable_list%var_pointer, total_nvars, variable_list%diag_field_indices) deallocate(diag_file_ids) + diag_yaml_module_initialized = .true. end subroutine !> @brief Destroys the diag_yaml object From b74b2102dc4d09b7e2f8d8ac6c6b300fe8f3baa7 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Thu, 11 Aug 2022 15:37:30 -0400 Subject: [PATCH 06/11] Attempts to point to the diagFile to the diagYaml --- diag_manager/fms_diag_file_object.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 7b260c10bf..17b4855ef3 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -146,6 +146,7 @@ logical function fms_diag_files_object_init (files_array) set_ids_loop: do i= 1,nFiles !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array. !! This will be set in a add_axes + files_array(i)%FMS_diag_file%diag_yaml_file => diag_yaml%diag_files(i) if (files_array(i)%FMS_diag_file%has_file_sub_region()) then allocate(subRegionalFile_type :: files_array(i)%FMS_diag_file) obj => files_array(i)%FMS_diag_file From aa1ef948ef1becf6b95bd2dd78b067e256a7955a Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Fri, 12 Aug 2022 08:41:32 -0400 Subject: [PATCH 07/11] Fixes yaml ifdefs to compile without yaml --- diag_manager/diag_manager.F90 | 2 +- diag_manager/fms_diag_field_object.F90 | 11 +----- diag_manager/fms_diag_file_object.F90 | 18 +-------- diag_manager/fms_diag_object.F90 | 44 ++++++++++++++-------- diag_manager/fms_diag_object_container.F90 | 3 +- 5 files changed, 34 insertions(+), 44 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index a2eafdb38e..8651e18531 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -239,8 +239,8 @@ MODULE diag_manager_mod #ifdef use_yaml use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field use fms_diag_axis_object_mod, only: fms_diag_axis_object_end, fms_diag_axis_object_init - use fms_diag_object_mod, only:fms_diag_object #endif + use fms_diag_object_mod, only:fms_diag_object USE constants_mod, ONLY: SECONDS_PER_DAY diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index 5b4c1b96a8..5e84efa277 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -7,6 +7,7 @@ module fms_diag_field_object_mod !! The procedures of this object and the types are all in this module. The fms_dag_object is a type !! that contains all of the information of the variable. It is extended by a type that holds the !! appropriate buffer for the data for manipulation. +#ifdef use_yaml use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type @@ -15,10 +16,8 @@ module fms_diag_field_object_mod use diag_axis_mod, only: diag_axis_type use mpp_mod, only: fatal, note, warning, mpp_error -#ifdef use_yaml use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, & & find_diag_field, get_num_unique_fields -#endif use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type use time_manager_mod, ONLY: time_type !!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& @@ -32,11 +31,9 @@ module fms_diag_field_object_mod !> \brief Object that holds all variable information type fmsDiagField_type -#ifdef use_yaml type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable !! belongs to -#endif integer, allocatable, private :: diag_id !< unique id for varable type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable integer, private :: num_attributes !< Number of attributes currently added @@ -170,10 +167,8 @@ end subroutine fms_diag_field_object_end logical function fms_diag_fields_object_init(ob) class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object integer :: i !< For looping -#ifdef use_yaml allocate(ob(get_num_unique_fields())) registered_variables = 0 -#endif do i = 1,size(ob) ob(i)%diag_id = diag_not_registered !null_ob%diag_id ob(i)%registered = .false. @@ -218,7 +213,6 @@ subroutine fms_register_diag_field_obj & integer :: i !< For do loops integer :: j !< dobj%file_ids(i) (for less typing :) -#ifdef use_yaml !> Fill in information from the register call dobj%varname = trim(varname) dobj%modname = trim(modname) @@ -335,7 +329,6 @@ subroutine fms_register_diag_field_obj & allocate(dobj%attributes(max_field_attributes)) dobj%num_attributes = 0 dobj%registered = .true. -#endif end subroutine fms_register_diag_field_obj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief Sets the diag_id. This can only be done if a variable is unregistered @@ -961,5 +954,5 @@ PURE FUNCTION diag_field_id_from_name(diag_objs, module_name, field_name) & diag_field_id = diag_objs%get_id() endif end function diag_field_id_from_name - +#endif end module fms_diag_field_object_mod diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 17b4855ef3..1ebadf1a55 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -24,13 +24,12 @@ !! a pointer to the information from the diag yaml, additional metadata that comes from the model, and a !! list of the variables and their variable IDs that are in the file. module fms_diag_file_object_mod +#ifdef use_yaml use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED use diag_util_mod, only: diag_time_inc use time_manager_mod, only: time_type, operator(/=), operator(==) -#ifdef use_yaml use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type -#endif use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type use mpp_mod, only: mpp_error, FATAL implicit none @@ -54,9 +53,7 @@ module fms_diag_file_object_mod !< This will be used when using the new_file_freq keys in the diag_table.yaml TYPE(time_type) :: next_open !< The next time to open the file class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file -#ifdef use_yaml type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data -#endif integer :: type_of_domain !< The type of domain to use to open the file !! NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, SUB_REGIONAL class(diagDomain_t), pointer :: domain !< The domain to use, @@ -74,13 +71,11 @@ module fms_diag_file_object_mod procedure, public :: add_field_id procedure, public :: has_file_metadata_from_model procedure, public :: has_fileobj -#ifdef use_yaml procedure, public :: has_diag_yaml_file procedure, public :: set_domain_from_axis procedure, public :: set_file_domain procedure, public :: add_axes procedure, public :: add_start_time -#endif procedure, public :: has_field_ids procedure, public :: get_id ! TODO procedure, public :: get_fileobj ! TODO @@ -88,7 +83,6 @@ module fms_diag_file_object_mod procedure, public :: get_file_metadata_from_model procedure, public :: get_field_ids ! The following fuctions come will use the yaml inquiry functions -#ifdef use_yaml procedure, public :: get_file_fname procedure, public :: get_file_frequnit procedure, public :: get_file_freq @@ -116,7 +110,6 @@ module fms_diag_file_object_mod procedure, public :: has_file_duration_units procedure, public :: has_file_varlist procedure, public :: has_file_global_meta -#endif end type fmsDiagFile_type type, extends (fmsDiagFile_type) :: subRegionalFile_type @@ -135,7 +128,6 @@ module fms_diag_file_object_mod !< @brief Allocates the number of files and sets an ID based for each file !! @return true if there are files allocated in the YAML object logical function fms_diag_files_object_init (files_array) -#ifdef use_yaml class(fmsDiagFileContainer_type), allocatable, target, intent(inout) :: files_array (:) !< array of diag files class(fmsDiagFile_type), pointer :: obj => null() !< Pointer for each member of the array integer :: nFiles !< Number of files in the diag yaml @@ -192,9 +184,6 @@ logical function fms_diag_files_object_init (files_array) ! mpp_error("fms_diag_files_object_init: The diag_table.yaml file has not been correctly parsed.",& ! FATAL) endif -#else - fms_diag_files_object_init = .false. -#endif end function fms_diag_files_object_init !> \brief Adds a field ID to the file subroutine add_field_id (obj, new_field_id) @@ -225,14 +214,12 @@ pure logical function has_fileobj (obj) class(fmsDiagFile_type), intent(in) :: obj !< The file object has_fileobj = allocated(obj%fileobj) end function has_fileobj -#ifdef use_yaml !> \brief Logical function to determine if the variable diag_yaml_file has been allocated or associated !! \return .True. if diag_yaml_file exists .False. if diag_yaml has not been set pure logical function has_diag_yaml_file (obj) class(fmsDiagFile_type), intent(in) :: obj !< The file object has_diag_yaml_file = associated(obj%diag_yaml_file) end function has_diag_yaml_file -#endif !> \brief Logical function to determine if the variable field_ids has been allocated or associated !! \return .True. if field_ids exists .False. if field_ids has not been set pure logical function has_field_ids (obj) @@ -259,13 +246,11 @@ end function get_id !! TODO !!> \brief Returns a copy of the value of diag_yaml_file !!! \return A copy of diag_yaml_file -!#ifdef use_yaml !pure function get_diag_yaml_file (obj) result (res) ! class(fmsDiagFile_type), intent(in) :: obj !< The file object ! type(diagYamlFiles_type) :: res ! res = obj%diag_yaml_file !end function get_diag_yaml_file -!#endif !> \brief Returns a copy of the value of file_metadata_from_model !! \return A copy of file_metadata_from_model pure function get_file_metadata_from_model (obj) result (res) @@ -282,7 +267,6 @@ pure function get_field_ids (obj) result (res) res = obj%field_ids end function get_field_ids !!!!!!!!! Functions from diag_yaml_file -#ifdef use_yaml !> \brief Returns a copy of file_fname from the yaml object !! \return Copy of file_fname pure function get_file_fname (obj) result(res) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 4e2b4ddb4a..f3aea5ba2f 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -17,21 +17,24 @@ !* License along with FMS. If not, see . !*********************************************************************** module fms_diag_object_mod -use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init -use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init -use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id -use fms_diag_axis_object_mod, only: fms_diag_axis_object_init +use mpp_mod, only: fatal, note, warning, mpp_error use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & - &DIAG_FIELD_NOT_FOUND + &DIAG_FIELD_NOT_FOUND, diag_not_registered USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & & get_ticks_per_second - +#ifdef use_yaml +use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init +use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init +use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id +use fms_diag_axis_object_mod, only: fms_diag_axis_object_init +#endif implicit none private type fmsDiagObject_type !TODO add container arrays +#ifdef use_yaml private class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields @@ -41,7 +44,7 @@ module fms_diag_object_mod logical, private :: fields_initialized=.false. !< True if the fmsDiagObject is initialized logical, private :: buffers_initialized=.false. !< True if the fmsDiagObject is initialized logical, private :: axes_initialized=.false. !< True if the fmsDiagObject is initialized - +#endif contains procedure :: init => fms_diag_object_init procedure :: fms_register_diag_field_scalar @@ -55,7 +58,6 @@ module fms_diag_object_mod type (fmsDiagObject_type), target :: fms_diag_object integer, private :: registered_variables !< Number of registered variables - public :: fms_register_diag_field_obj public :: fms_register_diag_field_scalar public :: fms_register_diag_field_array @@ -74,9 +76,9 @@ module fms_diag_object_mod subroutine fms_diag_object_init (obj,diag_subset_output) class(fmsDiagObject_type) :: obj !< Diag mediator/controller object integer :: diag_subset_output !< Subset of the diag output? - - if (obj%initialized) return #ifdef use_yaml + if (obj%initialized) return + !TODO: Read name list !TODO: Read YAML !TODO: allocate the file, field, and buffer containers @@ -86,10 +88,11 @@ subroutine fms_diag_object_init (obj,diag_subset_output) obj%files_initialized = fms_diag_files_object_init(obj%FMS_diag_files) obj%fields_initialized = fms_diag_fields_object_init (obj%FMS_diag_fields) registered_variables = 0 + obj%initialized = .true. #else - !TODO: FATAL modern diag requires the use of yaml + call mpp_error("fms_diag_object_init",& + "You must compile with -Duse_yaml to use the option use_modern_diag", FATAL) #endif - obj%initialized = .true. end subroutine fms_diag_object_init !> \description Loops through all files and does one final write. !! Closes all files @@ -97,10 +100,12 @@ end subroutine fms_diag_object_init !! Uninitializes the fms_diag_object subroutine fms_diag_object_end (obj) class(fmsDiagObject_type) :: obj +#ifdef use_yaml !TODO: loop through files and force write !TODO: Close all files !TODO: Deallocate diag object arrays and clean up all memory obj%initialized = .false. +#endif end subroutine fms_diag_object_end !> \Description Fills in and allocates (when necessary) the values in the diagnostic object subroutine fms_register_diag_field_obj & @@ -133,6 +138,7 @@ subroutine fms_register_diag_field_obj & INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the !! modeling_realm attribute +#ifdef use_yaml class (fmsDiagFile_type), pointer :: fileptr => null() class (fmsDiagField_type), pointer :: fieldptr => null() @@ -140,7 +146,6 @@ subroutine fms_register_diag_field_obj & integer :: i !< For do loops integer :: j !< fms_diag_object%FMS_diag_fields%file_ids(i) (for less typing :) -#ifdef use_yaml !> Use pointers for convenience fieldptr => fms_diag_object%FMS_diag_fields(registered_variables) !> Register the data for the field @@ -227,8 +232,9 @@ INTEGER FUNCTION fms_register_diag_field_scalar(fms_diag_object,module_name, fie & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & area=area, volume=volume, realm=realm) deallocate(diag_field_indices) +#else +fms_register_diag_field_scalar = diag_not_registered #endif - end function fms_register_diag_field_scalar !> @brief Registers an array field @@ -280,8 +286,9 @@ INTEGER FUNCTION fms_register_diag_field_array(fms_diag_object, module_name, fie & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) deallocate(diag_field_indices) +#else +fms_register_diag_field_array = diag_not_registered #endif - end function fms_register_diag_field_array !> @brief Return field index for subsequent call to send_data. @@ -336,6 +343,8 @@ INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_n & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, & & static=.true.) deallocate(diag_field_indices) +#else +fms_register_static_field = diag_not_registered #endif end function fms_register_static_field @@ -345,12 +354,14 @@ subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to character(len=*), intent(in) :: att_name !< Name of the attribute class(*), intent(in) :: att_value(:) !< The attribute value to add +#ifdef use_yaml if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) then call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value) else !TODO: add error call endif +#endif end subroutine fms_diag_field_add_attribute !> \brief Gets the diag field ID from the module name and field name. !> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered @@ -363,12 +374,13 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel integer :: i !< For looping !> Initialize to not found diag_field_id = DIAG_FIELD_NOT_FOUND +#ifdef use_yaml !> Loop through fields to find it. if (registered_variables < 1) return do i=1,registered_variables diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name) if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return enddo +#endif END FUNCTION fms_get_diag_field_id_from_name - end module fms_diag_object_mod diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90 index 8e397720a1..ef05b3578f 100644 --- a/diag_manager/fms_diag_object_container.F90 +++ b/diag_manager/fms_diag_object_container.F90 @@ -40,6 +40,7 @@ !> @addtogroup fms_diag_object_container_mod !> @{ MODULE fms_diag_object_container_mod +#ifdef use_yaml use fms_diag_field_object_mod, only: fmsDiagField_type USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE @@ -284,7 +285,7 @@ subroutine destructor(this) this%the_linked_list =>null() end subroutine destructor - +#endif end module fms_diag_object_container_mod !> @} ! close documentation grouping From 900a0e06f5679117c6bae0f2501dde91efe26486 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Fri, 12 Aug 2022 09:41:28 -0400 Subject: [PATCH 08/11] Fixes a pointer error in the diag oibject --- diag_manager/fms_diag_file_object.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 1ebadf1a55..6d30e414c2 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -138,8 +138,7 @@ logical function fms_diag_files_object_init (files_array) set_ids_loop: do i= 1,nFiles !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array. !! This will be set in a add_axes - files_array(i)%FMS_diag_file%diag_yaml_file => diag_yaml%diag_files(i) - if (files_array(i)%FMS_diag_file%has_file_sub_region()) then + if (diag_yaml%diag_files(i)%has_file_sub_region()) then allocate(subRegionalFile_type :: files_array(i)%FMS_diag_file) obj => files_array(i)%FMS_diag_file obj%type_of_domain = SUB_REGIONAL From b87088c9ec7142bf7f81a55cff7ddd87917a4c99 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Fri, 12 Aug 2022 14:33:42 -0400 Subject: [PATCH 09/11] Fixes a check for to make sure the diag id is valid --- diag_manager/fms_diag_object.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index f3aea5ba2f..64a71c9f37 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -355,11 +355,12 @@ subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name character(len=*), intent(in) :: att_name !< Name of the attribute class(*), intent(in) :: att_value(:) !< The attribute value to add #ifdef use_yaml - - if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) then - call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value) +!TODO: Value for diag not found + if ( diag_field_id .LE. 0 ) THEN + RETURN else - !TODO: add error call + if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) & + call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value) endif #endif end subroutine fms_diag_field_add_attribute From 13211c0699a5b7a054e891e91091690b535828bc Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Mon, 15 Aug 2022 14:33:52 -0400 Subject: [PATCH 10/11] Resolves comments in #1017 --- diag_manager/fms_diag_field_object.F90 | 4 ---- diag_manager/fms_diag_file_object.F90 | 20 ++++++++++---------- diag_manager/fms_diag_object.F90 | 7 +------ 3 files changed, 11 insertions(+), 20 deletions(-) diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index 5e84efa277..afe84dc119 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -56,8 +56,6 @@ module fms_diag_field_object_mod !! Valid options are "conserve_order1", !! "conserve_order2", and "none". integer, allocatable, dimension(:), private :: frequency !< specifies the frequency - integer, allocatable, dimension(:), private :: output_units - integer, allocatable, private :: t integer, allocatable, private :: tile_count !< The number of tiles integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs class(diagDomain_t), pointer, private :: domain !< Domain @@ -70,7 +68,6 @@ module fms_diag_field_object_mod ! procedure :: send_data => fms_send_data !!TODO ! Get ID functions procedure :: get_id => fms_diag_get_id - procedure :: id => fms_diag_get_id procedure :: id_from_name => diag_field_id_from_name procedure :: copy => copy_diag_obj procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. @@ -110,7 +107,6 @@ module fms_diag_field_object_mod procedure :: has_missing_value procedure :: has_data_RANGE ! Get functions - procedure :: get_diag_id => fms_diag_get_id procedure :: get_attributes procedure :: get_static procedure :: get_registered diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 6d30e414c2..3f11a7174b 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -64,6 +64,8 @@ module fms_diag_file_object_mod logical, dimension(:), private, allocatable :: field_registered !< Array corresponding to `field_ids`, .true. !! if the variable has been registered and !! `field_id` has been set for the variable + integer, allocatable :: num_registered_fields !< The number of fields registered + !! to the file integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file integer :: number_of_axis !< Number of axis in the file @@ -159,6 +161,7 @@ logical function fms_diag_files_object_init (files_array) !! Initialize the integer arrays obj%field_ids = DIAG_NOT_REGISTERED obj%field_registered = .FALSE. + obj%num_registered_fields = 0 !> These will be set in a set_file_domain obj%type_of_domain = NO_DOMAIN @@ -188,17 +191,14 @@ end function fms_diag_files_object_init subroutine add_field_id (obj, new_field_id) class(fmsDiagFile_type), intent(inout) :: obj !< The file object integer, intent(in) :: new_field_id !< The field ID to be added to field_ids - integer :: i !< For looping - do i = 1, size(obj%field_ids) - if (.not.obj%field_registered(i)) then - obj%field_ids(i) = new_field_id - obj%field_registered(i) = .true. - return - endif - enddo - - call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has already been assigned its maximum "//& + obj%num_registered_fields = obj%num_registered_fields + 1 + if (obj%num_registered_fields .le. size(obj%field_ids)) then + obj%field_ids( obj%num_registered_fields ) = new_field_id + obj%field_registered( obj%num_registered_fields ) = .true. + else + call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has already been assigned its maximum "//& "number of fields.") + endif end subroutine add_field_id !> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 64a71c9f37..f746c029d6 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -36,6 +36,7 @@ module fms_diag_object_mod !TODO add container arrays #ifdef use_yaml private +!TODO: Remove FMS prefix from variables in this type class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields integer, private :: registered_variables !< Number of registered variables @@ -79,8 +80,6 @@ subroutine fms_diag_object_init (obj,diag_subset_output) #ifdef use_yaml if (obj%initialized) return -!TODO: Read name list -!TODO: Read YAML !TODO: allocate the file, field, and buffer containers ! allocate(diag_objs(get_num_unique_fields())) CALL diag_yaml_object_init(diag_subset_output) @@ -184,10 +183,6 @@ subroutine fms_register_diag_field_obj & endif nullify (fileptr) nullify (fieldptr) - !TODO: - !! Mark the field as registered in the diag_files - !! DO we actually need this? - #endif end subroutine fms_register_diag_field_obj From a606f4fb292ea2375b34dc9d498152162d4eca89 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Mon, 15 Aug 2022 14:41:08 -0400 Subject: [PATCH 11/11] removes output_units and t from field object --- diag_manager/fms_diag_field_object.F90 | 42 -------------------------- 1 file changed, 42 deletions(-) diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index afe84dc119..559bd4e423 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -99,8 +99,6 @@ module fms_diag_field_object_mod procedure :: has_realm procedure :: has_interp_method procedure :: has_frequency - procedure :: has_output_units - procedure :: has_t procedure :: has_tile_count procedure :: has_area procedure :: has_volume @@ -121,8 +119,6 @@ module fms_diag_field_object_mod procedure :: get_realm procedure :: get_interp_method procedure :: get_frequency - procedure :: get_output_units - procedure :: get_t procedure :: get_tile_count procedure :: get_area procedure :: get_volume @@ -642,32 +638,6 @@ pure function get_frequency (obj) & rslt = DIAG_NULL endif end function get_frequency -!> @brief Gets output_units -!! @return copy of The units of the output or DIAG_NULL is output_units is not allocated -pure function get_output_units (obj) & -result(rslt) - class (fmsDiagField_type), intent(in) :: obj !< diag object - integer,allocatable, dimension (:) :: rslt - if (allocated(obj%output_units)) then - allocate (rslt(size(obj%output_units))) - rslt = obj%output_units - else - allocate (rslt(1)) - rslt = DIAG_NULL - endif -end function get_output_units -!> @brief Gets t -!! @return copy of t -pure function get_t (obj) & -result(rslt) - class (fmsDiagField_type), intent(in) :: obj !< diag object - integer :: rslt - if (allocated(obj%t)) then - rslt = obj%t - else - rslt = -999 - endif -end function get_t !> @brief Gets tile_count !! @return copy of the number of tiles or diag_null if tile_count is not allocated pure function get_tile_count (obj) & @@ -877,18 +847,6 @@ pure logical function has_frequency (obj) class (fmsDiagField_type), intent(in) :: obj !< diag object has_frequency = allocated(obj%frequency) end function has_frequency -!> @brief Checks if obj%output_units is allocated -!! @return true if obj%output_units is allocated -pure logical function has_output_units (obj) - class (fmsDiagField_type), intent(in) :: obj !< diag object - has_output_units = allocated(obj%output_units) -end function has_output_units -!> @brief Checks if obj%t is allocated -!! @return true if obj%t is allocated -pure logical function has_t (obj) - class (fmsDiagField_type), intent(in) :: obj !< diag object - has_t = allocated(obj%t) -end function has_t !> @brief Checks if obj%tile_count is allocated !! @return true if obj%tile_count is allocated pure logical function has_tile_count (obj)