From e3113ebd9d62b18b549b9d698f5679acec63aa10 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 6 Oct 2021 13:53:24 -0400 Subject: [PATCH 001/142] First attempt at adding the fms_diag_object to diag manager --- diag_manager/Makefile.am | 13 +- diag_manager/diag_data.F90 | 51 ++- diag_manager/diag_yaml.c | 6 + diag_manager/diag_yaml.h | 28 ++ diag_manager/fms_diag_object.F90 | 547 +++++++++++++++++++++++++++++++ diag_manager/fms_diag_yaml.F90 | 32 ++ 6 files changed, 674 insertions(+), 3 deletions(-) create mode 100644 diag_manager/diag_yaml.c create mode 100644 diag_manager/diag_yaml.h create mode 100644 diag_manager/fms_diag_object.F90 create mode 100644 diag_manager/fms_diag_yaml.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 295b4e3bb5..c280ca86ab 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -37,15 +37,22 @@ libdiag_manager_la_SOURCES = \ diag_manager.F90 \ diag_output.F90 \ diag_table.F90 \ - diag_util.F90 + diag_util.F90 \ + fms_diag_yaml.F90 \ + diag_yaml.h \ + diag_yaml.c \ + fms_diag_object.F90 # Some mods are dependant on other mods in this dir. diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_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_yaml_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_object_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ @@ -55,6 +62,8 @@ MODFILES = \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ + fms_diag_yaml_mod.$(FC_MODEXT) \ + fms_diag_object_mod.$(FC_MODEXT) \ diag_manager_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 33199cc8cd..6a2990d4c1 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -60,12 +60,34 @@ MODULE diag_data_mod USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL #endif use fms2_io_mod - + use iso_c_binding IMPLICIT NONE PUBLIC ! Specify storage limits for fixed size tables used for pointers, etc. + integer, parameter :: diag_null = -999 !< Integer represening NULL in the diag_object + integer, parameter :: diag_not_found = -1 + integer, parameter :: diag_not_registered = 0 + integer, parameter :: diag_registered_id = 10 + !> Supported averaging intervals + integer, parameter :: monthly = 30 + integer, parameter :: daily = 24 + integer, parameter :: diurnal = 2 + integer, parameter :: yearly = 12 + integer, parameter :: no_diag_averaging = 0 + integer, parameter :: instantaneous = 0 + integer, parameter :: three_hourly = 3 + integer, parameter :: six_hourly = 6 + !integer, parameter :: seasonally = 180 + !> Supported type/kind of the variable + !integer, parameter :: r16=16 + integer, parameter :: r8 = 8 + integer, parameter :: r4 = 4 + integer, parameter :: i8 = -8 + integer, parameter :: i4 = -4 + integer, parameter :: string = 19 !< s is the 19th letter of the alphabet + integer, parameter :: null_type_int = -999 INTEGER, PARAMETER :: MAX_FIELDS_PER_FILE = 300 !< Maximum number of fields per file. INTEGER, PARAMETER :: DIAG_OTHER = 0 INTEGER, PARAMETER :: DIAG_OCEAN = 1 @@ -86,6 +108,33 @@ MODULE diag_data_mod !> @} + + !> @brief The files type matching a C struct containing diag_yaml information + !> @ingroup diag_data_mod +type, bind(c) :: diag_files_type + character (kind=c_char) :: fname (20) !< file name + character (kind=c_char) :: frequnit (7) !< the frequency unit + integer (c_int) :: freq !< the frequency of data + character (kind=c_char) :: timeunit(7) !< The unit of time + character (kind=c_char) :: unlimdim(8) !< The name of the unlimited dimension + character (kind=c_char) :: key(8) !< Storage for the key in the yaml file +end type diag_files_type +!> @brief The field type matching the C struct for diag_yaml information + !> @ingroup diag_data_mod +type, bind(c) :: diag_fields_type + character (kind=c_char) :: fname (20) !< The field/diagnostic name + character (kind=c_char) :: var(20) !< The name of the variable + character (kind=c_char) :: files(20) !< The files that the diagnostic will be written to + integer (c_int) :: ikind !< The type/kind of the variable + character (kind=c_char) :: skind(20) !< The type/kind of the variable + character (kind=c_char) :: reduction(20) !< IDK + character (kind=c_char) :: all_all(4) !< This has to be "all" + character (kind=c_char) :: region(50) !< The region + character (kind=c_char) :: regcoord(50) !< Coodinates of the region + character (kind=c_char) :: module_location(20) !< The module + character (kind=c_char) :: key(8) !< Storage for the key in the yaml file +end type diag_fields_type + !> @brief Contains the coordinates of the local domain to output. !> @ingroup diag_data_mod TYPE diag_grid diff --git a/diag_manager/diag_yaml.c b/diag_manager/diag_yaml.c new file mode 100644 index 0000000000..3dbb680da3 --- /dev/null +++ b/diag_manager/diag_yaml.c @@ -0,0 +1,6 @@ +#include +#include +#include +#include +#include + diff --git a/diag_manager/diag_yaml.h b/diag_manager/diag_yaml.h new file mode 100644 index 0000000000..fe1c9212ed --- /dev/null +++ b/diag_manager/diag_yaml.h @@ -0,0 +1,28 @@ +#include +#include +#include +#include +typedef struct diag_files { + char name [20]; + char frequnit [7]; + int freq; + char timeunit [7]; + char unlimdim [8]; + char key [8]; +} files; + + +typedef struct diag_fields { + char name[20]; + char var[20]; + char files[20]; + int intkind; + char skind[20]; + char reduction[20]; + char all[4]; + char region[50]; + char regcoord[50]; + char module[20]; + char key [8]; +} fields; + diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 new file mode 100644 index 0000000000..41d4756307 --- /dev/null +++ b/diag_manager/fms_diag_object.F90 @@ -0,0 +1,547 @@ +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 +use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int +use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id +use fms_diag_yaml_mod, only: is_field_type_null +use fms_diag_yaml_mod, only: diag_fields_type, diag_files_type, get_diag_table_field +use diag_axis_mod, only: diag_axis_type +use mpp_mod, only: fatal, note, warning, mpp_error +!use diag_util_mod, only: int_to_cs, logical_to_cs +!USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND + +use fms2_io_mod +use iso_c_binding + +implicit none + +interface operator (<) + procedure obj_lt_int + procedure int_lt_obj +end interface +interface operator (<=) + procedure obj_le_int + procedure int_le_obj +end interface +interface operator (>) + procedure obj_gt_int + procedure int_gt_obj +end interface +interface operator (>=) + procedure obj_ge_int + procedure int_ge_obj +end interface +interface operator (==) + procedure obj_eq_int + procedure int_eq_obj +end interface +interface operator (.ne.) + procedure obj_ne_int + procedure int_ne_obj +end interface + + +!> \brief Object that holds all variable information +type fms_diag_object + type (diag_fields_type) :: diag_field !< info from diag_table + type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table + integer, allocatable, private :: diag_id !< unique id for varable + class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the + !! file objects for this variable + character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable + logical, private :: static !< true is this is a static var + logical, allocatable, private :: registered !< true when registered + integer, allocatable, dimension(:), private :: frequency !< specifies the frequency + + 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 :: units !< the units + character(len=:), allocatable, private :: modname !< the module + integer, private :: missing_value !< The missing fill value + integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs + type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object + + contains +! procedure :: send_data => fms_send_data !!TODO + procedure :: init_ob => diag_obj_init + procedure :: diag_id_inq => fms_diag_id_inq + procedure :: copy => copy_diag_obj + procedure :: register_meta => fms_register_diag_field_obj + procedure :: setID => set_diag_id + procedure :: is_registered => diag_ob_registered + procedure :: set_type => set_vartype + procedure :: vartype_inq => what_is_vartype + + procedure :: is_static => diag_obj_is_static + procedure :: is_registeredB => diag_obj_is_registered + procedure :: get_vartype => diag_obj_get_vartype + procedure :: get_varname => diag_obj_get_varname + +end type fms_diag_object +!> \brief Extends the variable object to work with multiple types of data +type, extends(fms_diag_object) :: fms_diag_object_scalar + class(*), allocatable :: vardata +end type fms_diag_object_scalar +type, extends(fms_diag_object) :: fms_diag_object_1d + class(*), allocatable, dimension(:) :: vardata +end type fms_diag_object_1d +type, extends(fms_diag_object) :: fms_diag_object_2d + class(*), allocatable, dimension(:,:) :: vardata +end type fms_diag_object_2d +type, extends(fms_diag_object) :: fms_diag_object_3d + class(*), allocatable, dimension(:,:,:) :: vardata +end type fms_diag_object_3d +type, extends(fms_diag_object) :: fms_diag_object_4d + class(*), allocatable, dimension(:,:,:,:) :: vardata +end type fms_diag_object_4d +type, extends(fms_diag_object) :: fms_diag_object_5d + class(*), allocatable, dimension(:,:,:,:,:) :: vardata +end type fms_diag_object_5d +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +type(fms_diag_object) :: null_ob +type(fms_diag_object_scalar) :: null_sc +type(fms_diag_object_1d) :: null_1d +type(fms_diag_object_2d) :: null_2d +type(fms_diag_object_3d) :: null_3d +type(fms_diag_object_4d) :: null_4d +type(fms_diag_object_5d) :: null_5d + +integer,private :: MAX_LEN_VARNAME +integer,private :: MAX_LEN_META +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d +public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d +public :: copy_diag_obj, fms_diag_id_inq +public :: operator (>),operator (<),operator (>=),operator (<=),operator (==),operator (.ne.) +public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d +public :: fms_diag_object_init +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +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 +!> Get info from the namelist + MAX_LEN_VARNAME = mlv + MAX_LEN_META = mlm +!> Initialize the null_d variables + null_ob%diag_id = DIAG_NULL + null_sc%diag_id = DIAG_NULL + null_1d%diag_id = DIAG_NULL + null_2d%diag_id = DIAG_NULL + null_3d%diag_id = DIAG_NULL + null_4d%diag_id = DIAG_NULL + null_5d%diag_id = DIAG_NULL +end subroutine fms_diag_object_init +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \Description Sets the diag_id to the not registered value. +subroutine diag_obj_init(ob) + class (fms_diag_object) , intent(inout) :: ob + select type (ob) + class is (fms_diag_object) + ob%diag_id = diag_not_registered !null_ob%diag_id + 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) + class(fms_diag_object) , intent(inout) :: dobj + character(*) , intent(in) :: modname!< The module name + character(*) , intent(in) :: varname!< The variable name + integer , dimension(:) , intent(in), optional :: axes !< Th character(:),allocatable :: rese axes + integer , intent(in), optional :: time !< Time placeholder + character(*) , intent(in), optional :: longname!< The variable long name + character(*) , intent(in), optional :: units !< Units of the variable + integer , intent(in), optional :: missing_value !< A missing value to be used + character(*), dimension(:) , intent(in), optional :: metadata +! class(*), pointer :: vptr + + +!> Fill in information from the register call + allocate(character(len=MAX_LEN_VARNAME) :: dobj%varname) + dobj%varname = trim(varname) + allocate(character(len=len(modname)) :: dobj%modname) + dobj%modname = trim(modname) +!> Grab the information from the diag_table + dobj%diag_field = get_diag_table_field(trim(varname)) + if (is_field_type_null(dobj%diag_field)) then + dobj%diag_id = diag_not_found + dobj%vartype = diag_null + return + endif +!> get the optional arguments if included and the diagnostic is in the diag table + if (present(longname)) then + allocate(character(len=len(longname)) :: dobj%longname) + dobj%longname = trim(longname) + endif + if (present(units)) then + allocate(character(len=len(units)) :: dobj%units) + dobj%units = trim(units) + endif + if (present(metadata)) then + allocate(character(len=MAX_LEN_META) :: dobj%metadata(size(metadata))) + dobj%metadata = metadata + endif + if (present(missing_value)) then + dobj%missing_value = missing_value + else + dobj%missing_value = DIAG_NULL + endif + +! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind +! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind +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 (fms_diag_object) , 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 (fms_diag_object) , 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 (fms_diag_object) , 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 (fms_diag_object) , 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 (fms_diag_object) , intent(in) :: objin + class (fms_diag_object) , intent(inout) , allocatable :: objout !< The destination of the copy +select type (objout) + class is (fms_diag_object) + + 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 +! type (diag_fields_type) :: diag_field !< info from diag_table +! type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table + + objout%diag_id = objin%diag_id + +! class (fms_io_obj), allocatable, dimension(:) :: fms_fileobj !< fileobjs + if (allocated(objin%metadata)) objout%metadata = objin%metadata + 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 diag_id +integer function fms_diag_id_inq (dobj) result(diag_id) + class(fms_diag_object) , intent(inout) :: dobj +! character(*) , intent(in) :: varname + + if (.not.allocated(dobj%registered)) then + call mpp_error ("fms_what_is_my_id","The diag object was not registered", fatal) + endif + diag_id = dobj%diag_id +end function fms_diag_id_inq + +!> 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(fms_diag_object), 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(fms_diag_object), intent(in) :: obj + logical :: rslt + rslt = obj%registered +end function diag_obj_is_registered + +function diag_obj_is_static (obj) result (rslt) + class(fms_diag_object), intent(in) :: obj + logical :: rslt + rslt = obj%static +end function diag_obj_is_static + +function diag_obj_get_vartype (obj) result (rslt) + class(fms_diag_object), intent(in) :: obj + integer :: rslt + rslt = obj%vartype +end function diag_obj_get_vartype + +function diag_obj_get_varname(obj) result (rslt) + class(fms_diag_object), intent(in) :: obj + character(len=len(obj%varname)) :: rslt + rslt = obj%varname +end function diag_obj_get_varname + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> \brief override for checking if object ID is greater than an integer (IDs) +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function obj_gt_int (obj,i) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i >= diag_not_registered) then + ll = .false. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (obj%diag_id > i) + endif +end function obj_gt_int +!> \brief override for checking if integer (ID) is greater than an object ID +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function int_gt_obj (i,obj) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i <= diag_not_registered) then + ll = .false. + elseif (.not.allocated(obj)) then + ll = .true. + else + ll = (i > obj%diag_id) + endif +end function int_gt_obj +!> \brief override for checking if object ID is less than an integer (IDs) +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function obj_lt_int (obj,i) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i > diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj)) then + ll = .false. + else + ll = (obj%diag_id < i) + endif +end function obj_lt_int +!> \brief override for checking if integer (ID) is less than an object ID +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function int_lt_obj (i,obj) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i >= diag_not_registered) then + ll = .false. + elseif (.not.allocated(obj)) then + ll = .true. + else + ll = (i < obj%diag_id) + endif +end function int_lt_obj +!> \brief override for checking if object ID is greater than or equal to an integer (IDs) +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function obj_ge_int (obj,i) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i <= diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (obj%diag_id >= i) + endif +end function obj_ge_int +!> \brief override for checking if integer (ID) is greater than or equal to an object ID +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function int_ge_obj (i,obj) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i >= diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (i >= obj%diag_id) + endif +end function int_ge_obj +!> \brief override for checking if object ID is less than or equal to an integer (IDs) +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function obj_le_int (obj,i) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i >= diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (obj%diag_id <= i) + endif +end function obj_le_int +!> \brief override for checking if integer (ID) is less than or equal to an object ID +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function int_le_obj (i,obj) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i <= diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (i <= obj%diag_id) + endif +end function int_le_obj +!> \brief override for checking if object ID is equal to an integer (IDs) +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function obj_eq_int (obj,i) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i == diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (obj%diag_id == i) + endif +end function obj_eq_int +!> \brief override for checking if integer (ID) is equal to an object ID +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function int_eq_obj (i,obj) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i == diag_not_registered) then + ll = .true. + elseif (.not.allocated(obj) ) then + ll = .false. + else + ll = (i == obj%diag_id) + endif +end function int_eq_obj + +!> \brief override for checking if object ID is not equal to an integer (IDs) +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function obj_ne_int (obj,i) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i == diag_not_registered) then + ll = .false. + elseif (.not.allocated(obj) ) then + ll = .true. + else + ll = (obj%diag_id .ne. i) + endif +end function obj_ne_int + +!> \brief override for checking if integer (ID) is not equal to an object ID +!> @note unalloacted obj is assumed to equal diag_not_registered +pure logical function int_ne_obj (i,obj) result(ll) + class (fms_diag_object), intent(in), allocatable :: obj + integer, intent(in) :: i + if (.not.allocated(obj) .and. i == diag_not_registered) then + ll = .false. + elseif (.not.allocated(obj) ) then + ll = .true. + else + ll = (i .ne. obj%diag_id) + endif +end function int_ne_obj + +end module fms_diag_object_mod diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 new file mode 100644 index 0000000000..e565f7c9a1 --- /dev/null +++ b/diag_manager/fms_diag_yaml.F90 @@ -0,0 +1,32 @@ +module fms_diag_yaml_mod + +use fms_diag_data_mod, only: diag_files_type, diag_fields_type + +contains +!> \brief Compares two field type variables +pure logical function is_field_type_null (in1) +type(diag_fields_type), intent(in) :: in1 +is_field_type_null = (in1%ikind == DIAG_NULL) +end function is_field_type_null + +!!TODO +!> \brief looks for a diag_field based on it's name. +!! Returns null if field is not found. +type(diag_fields_type)function get_diag_table_field (field_name) result (field) + character(len=*), intent(IN) :: field_name + integer :: i +! do i = 1,size(diag_fields) +! if (trim(field_name) == trim(fms_c2f_string(diag_fields(i)%fname))) then +! field = diag_fields(i) +!write (6,*) field_name//" Found" +! +! return +! endif +! enddo +! field = null_field_type + +end function get_diag_table_field + + + +end module fms_diag_yaml_mod From a9982d80547842898d39e63e5de68b27ca9ac609 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 6 Oct 2021 14:13:48 -0400 Subject: [PATCH 002/142] Second attempt at adding the fms_diag_object to diag manager --- diag_manager/Makefile.am | 7 ++++--- diag_manager/fms_diag_yaml.F90 | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index c280ca86ab..536b7e7b93 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -46,10 +46,11 @@ libdiag_manager_la_SOURCES = \ # Some mods are dependant on other mods in this dir. diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) -diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) +diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) \ + diag_yaml.h 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_yaml_mod.$(FC_MODEXT) +fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) diag_yaml.h +fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) diag_yaml.h diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ fms_diag_object_mod.$(FC_MODEXT) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index e565f7c9a1..f96c50ac84 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -1,6 +1,6 @@ module fms_diag_yaml_mod -use fms_diag_data_mod, only: diag_files_type, diag_fields_type +use diag_data_mod, only: diag_files_type, diag_fields_type contains !> \brief Compares two field type variables From ce9de8ad63dada9bb1cbdfebfdfc34d76ae82d21 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 6 Oct 2021 14:57:38 -0400 Subject: [PATCH 003/142] Adds diag_object to diag_manager folder and compiles. --- diag_manager/Makefile.am | 2 +- diag_manager/diag_axis.F90 | 2 +- diag_manager/diag_yaml.c | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 536b7e7b93..50ff238366 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index faf1c4909a..d6c3d270cf 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -57,7 +57,7 @@ MODULE diag_axis_mod & get_axis_num, get_diag_axis_domain_name, diag_axis_add_attribute,& & get_domainUG, axis_compatible_check, axis_is_compressed, & & get_compressed_axes_ids, get_axis_reqfld, & - & NORTH, EAST, CENTER + & NORTH, EAST, CENTER, diag_axis_type ! Include variable "version" to be written to log file #include diff --git a/diag_manager/diag_yaml.c b/diag_manager/diag_yaml.c index 3dbb680da3..29100fd997 100644 --- a/diag_manager/diag_yaml.c +++ b/diag_manager/diag_yaml.c @@ -1,6 +1,6 @@ -#include +/** #include **/ #include #include #include -#include +/** #include **/ From 98bb81e0f32b2a7c5646f953e7231daec052a367 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 20 Oct 2021 09:33:40 -0400 Subject: [PATCH 004/142] Adds namelist variable --- diag_manager/diag_data.F90 | 1 + diag_manager/diag_manager.F90 | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 6a2990d4c1..0cc043b0ec 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -376,6 +376,7 @@ MODULE diag_data_mod LOGICAL :: prepend_date = .TRUE. !< Should the history file have the start date prepended to the file name. !! .TRUE. is only supported if the diag_manager_init !! routine is called with the optional time_init parameter. + LOGICAL :: use_modern_diag = .false. !< Namelist flag to use the modernized diag_manager code LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io ! diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index ae82083476..333dfc4250 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -221,7 +221,7 @@ MODULE diag_manager_mod & use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,& & max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,& & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init, & - & use_mpp_io + & use_mpp_io, use_modern_diag USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att @@ -3560,7 +3560,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io + & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_mpp_io ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN From 9c9a406d89e6be620579495ebf426287f258f5f0 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Fri, 22 Oct 2021 14:12:22 -0400 Subject: [PATCH 005/142] Adds all variables to diag object that are registered. Adds dependency of fms_diag_object_mod to diag_manager_mod --- diag_manager/diag_manager.F90 | 1 + diag_manager/fms_diag_object.F90 | 117 ++++++++++++++++--------------- 2 files changed, 63 insertions(+), 55 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index ae82083476..d0b5a318f3 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -226,6 +226,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: fms_diag_object, diag_object_placeholder USE constants_mod, ONLY: SECONDS_PER_DAY #ifdef use_netCDF diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 41d4756307..c6f423268d 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -14,14 +14,22 @@ module fms_diag_object_mod use fms_diag_yaml_mod, only: diag_fields_type, diag_files_type, get_diag_table_field use diag_axis_mod, only: diag_axis_type use mpp_mod, only: fatal, note, warning, mpp_error +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 diag_util_mod, only: int_to_cs, logical_to_cs !USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND use fms2_io_mod +use platform_mod use iso_c_binding implicit none +integer, parameter :: range_dims = 2 !< The range of the variables will be set to 2 when allocated + interface operator (<) procedure obj_lt_int procedure int_lt_obj @@ -38,10 +46,10 @@ module fms_diag_object_mod procedure obj_ge_int procedure int_ge_obj end interface -interface operator (==) - procedure obj_eq_int - procedure int_eq_obj -end interface +!interface operator (==) +! procedure obj_eq_int +! procedure int_eq_obj +!end interface interface operator (.ne.) procedure obj_ne_int procedure int_ne_obj @@ -50,40 +58,63 @@ module fms_diag_object_mod !> \brief Object that holds all variable information type fms_diag_object - type (diag_fields_type) :: diag_field !< info from diag_table - type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table + type (diag_fields_type) :: diag_field !< info from diag_table + type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table integer, allocatable, private :: diag_id !< unique id for varable class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the !! file objects for this variable character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable - logical, private :: static !< true is this is a static var - logical, allocatable, private :: registered !< true when registered - integer, allocatable, dimension(:), private :: frequency !< specifies the frequency - + logical, private :: static !< true is 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 :: 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 - integer, private :: missing_value !< The missing fill value + character(len=:), allocatable, private :: realm !< String to set as the value + !! to the modeling_realm attribute + character(len=:), allocatable, private :: err_msg !< An error message + 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, allocatable, dimension(:), private :: axis_ids !< variable axis IDs - type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object - + integer, allocatable, private :: area, volume !< The Area and Volume + integer(kind=I4_KIND), allocatable :: i4missing_value !< The missing i4 fill value + integer(kind=I8_KIND), allocatable :: i8missing_value !< The missing i8 fill value + real(kind=R4_KIND), allocatable :: r4missing_value !< The missing r4 fill value + real(kind=R8_KIND), allocatable :: r8missing_value !< The missing r8 fill value + integer(kind=I4_KIND), allocatable,dimension(:) :: i4data_RANGE !< The range of i4 data + integer(kind=I8_KIND), allocatable,dimension(:) :: i8data_RANGE !< The range of i8 data + real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data + real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data + type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object + +!! dev variables that need to be removed + integer :: missing_value !< this should be removed contains ! procedure :: send_data => fms_send_data !!TODO - procedure :: init_ob => diag_obj_init - procedure :: diag_id_inq => fms_diag_id_inq - procedure :: copy => copy_diag_obj - procedure :: register_meta => fms_register_diag_field_obj - procedure :: setID => set_diag_id - procedure :: is_registered => diag_ob_registered - procedure :: set_type => set_vartype - procedure :: vartype_inq => what_is_vartype - - procedure :: is_static => diag_obj_is_static - procedure :: is_registeredB => diag_obj_is_registered - procedure :: get_vartype => diag_obj_get_vartype - procedure :: get_varname => diag_obj_get_varname + procedure,public :: init_ob => diag_obj_init + procedure,public :: diag_id_inq => fms_diag_id_inq + procedure,public :: copy => copy_diag_obj + procedure,public :: register_meta => fms_register_diag_field_obj + procedure,public :: setID => set_diag_id + procedure,public :: is_registered => diag_ob_registered + procedure,public :: set_type => set_vartype + procedure,public :: vartype_inq => what_is_vartype + + procedure,public :: is_static => diag_obj_is_static + procedure,public :: is_registeredB => diag_obj_is_registered + procedure,public :: get_vartype => diag_obj_get_vartype + procedure,public :: get_varname => diag_obj_get_varname end type fms_diag_object !> \brief Extends the variable object to work with multiple types of data @@ -116,11 +147,13 @@ module fms_diag_object_mod integer,private :: MAX_LEN_VARNAME integer,private :: MAX_LEN_META + +type(fms_diag_object_3d) :: diag_object_placeholder (10) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d public :: copy_diag_obj, fms_diag_id_inq -public :: operator (>),operator (<),operator (>=),operator (<=),operator (==),operator (.ne.) +public :: operator (>),operator (<),operator (>=),operator (<=),operator (.ne.)!operator (==),operator (.ne.) public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d public :: fms_diag_object_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -158,7 +191,7 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long class(fms_diag_object) , intent(inout) :: dobj character(*) , intent(in) :: modname!< The module name character(*) , intent(in) :: varname!< The variable name - integer , dimension(:) , intent(in), optional :: axes !< Th character(:),allocatable :: rese axes + integer , dimension(:) , intent(in), optional :: axes !< The character(:),allocatable :: rese axes integer , intent(in), optional :: time !< Time placeholder character(*) , intent(in), optional :: longname!< The variable long name character(*) , intent(in), optional :: units !< Units of the variable @@ -485,36 +518,10 @@ pure logical function int_le_obj (i,obj) result(ll) ll = .true. elseif (.not.allocated(obj) ) then ll = .false. - else + else ll = (i <= obj%diag_id) endif end function int_le_obj -!> \brief override for checking if object ID is equal to an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_eq_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i == diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (obj%diag_id == i) - endif -end function obj_eq_int -!> \brief override for checking if integer (ID) is equal to an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_eq_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i == diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (i == obj%diag_id) - endif -end function int_eq_obj !> \brief override for checking if object ID is not equal to an integer (IDs) !> @note unalloacted obj is assumed to equal diag_not_registered From ccb2583334879c22864fac7554c21114fabdcd95 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Fri, 22 Oct 2021 15:12:40 -0400 Subject: [PATCH 006/142] Registered a bunch of data in the diag_object. Calls the diag_object register from the regular diag array register if modern is turned on. --- diag_manager/diag_manager.F90 | 8 ++++ diag_manager/fms_diag_object.F90 | 69 +++++++++++++++++++++++--------- 2 files changed, 58 insertions(+), 19 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index c2cbc5e732..3d9ba7a925 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -583,6 +583,14 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t END DO END IF + + if (use_modern_diag) then + call diag_object_placeholder(1)%register & + (module_name, field_name, axes, init_time, & + long_name, units, missing_value, Range, mask_variant, standard_name, & + do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here) + endif + END FUNCTION register_diag_field_array !> @brief Return field index for subsequent call to send_data. diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index c6f423268d..5b3a52a957 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -88,24 +88,23 @@ module fms_diag_object_mod integer, allocatable, private :: tile_count !< The number of tiles integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs integer, allocatable, private :: area, volume !< The Area and Volume - integer(kind=I4_KIND), allocatable :: i4missing_value !< The missing i4 fill value - integer(kind=I8_KIND), allocatable :: i8missing_value !< The missing i8 fill value - real(kind=R4_KIND), allocatable :: r4missing_value !< The missing r4 fill value - real(kind=R8_KIND), allocatable :: r8missing_value !< The missing r8 fill value + real, private :: missing_value !< Holds a missing value if none given + integer(kind=I4_KIND), allocatable, private :: i4missing_value !< The missing i4 fill value + integer(kind=I8_KIND), allocatable, private :: i8missing_value !< The missing i8 fill value + real(kind=R4_KIND), allocatable, private :: r4missing_value !< The missing r4 fill value + real(kind=R8_KIND), allocatable, private :: r8missing_value !< The missing r8 fill value integer(kind=I4_KIND), allocatable,dimension(:) :: i4data_RANGE !< The range of i4 data integer(kind=I8_KIND), allocatable,dimension(:) :: i8data_RANGE !< The range of i8 data real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object -!! dev variables that need to be removed - integer :: missing_value !< this should be removed contains ! procedure :: send_data => fms_send_data !!TODO procedure,public :: init_ob => diag_obj_init procedure,public :: diag_id_inq => fms_diag_id_inq procedure,public :: copy => copy_diag_obj - procedure,public :: register_meta => fms_register_diag_field_obj + procedure,public :: register => fms_register_diag_field_obj procedure,public :: setID => set_diag_id procedure,public :: is_registered => diag_ob_registered procedure,public :: set_type => set_vartype @@ -187,18 +186,33 @@ subroutine diag_obj_init(ob) 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) +subroutine fms_register_diag_field_obj & + !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata) + (dobj, modname, varname, axes, init_time, & + longname, units, missing_value, varRange, mask_variant, standname, & + do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata) class(fms_diag_object) , intent(inout) :: dobj - character(*) , intent(in) :: modname!< The module name - character(*) , intent(in) :: varname!< The variable name - integer , dimension(:) , intent(in), optional :: axes !< The character(:),allocatable :: rese axes - integer , intent(in), optional :: time !< Time placeholder - character(*) , intent(in), optional :: longname!< The variable long name - character(*) , intent(in), optional :: units !< Units of the variable - integer , intent(in), optional :: missing_value !< A missing value to be used - character(*), dimension(:) , intent(in), optional :: metadata -! class(*), pointer :: vptr - + CHARACTER(len=*), INTENT(in) :: modname !< The module name + CHARACTER(len=*), INTENT(in) :: varname !< The variable name + INTEGER, INTENT(in) :: axes(:) !< The axes indicies + TYPE(time_type), INTENT(in) :: init_time !< Initial time + 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 + class(*), OPTIONAL, INTENT(in) :: varRANGE(2) + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant + 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 containing the cell area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id containing the cell volume field + CHARACTER(len=*), OPTIONAL, INTENT(in):: realm !< String to set as the value to the modeling_realm attribute + character(len=*), optional, intent(in), dimension(:) :: metadata !< metedata for the variable !> Fill in information from the register call allocate(character(len=MAX_LEN_VARNAME) :: dobj%varname) @@ -217,6 +231,10 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long allocate(character(len=len(longname)) :: dobj%longname) dobj%longname = trim(longname) endif + if (present(standname)) then + allocate(character(len=len(standname)) :: dobj%standname) + dobj%standname = trim(standname) + endif if (present(units)) then allocate(character(len=len(units)) :: dobj%units) dobj%units = trim(units) @@ -226,7 +244,20 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long dobj%metadata = metadata endif if (present(missing_value)) then - dobj%missing_value = missing_value + select type (missing_value) + type is (integer(kind=i4_kind)) + dobj%i4missing_value = missing_value + type is (integer(kind=i8_kind)) + dobj%i4missing_value = missing_value + type is (real(kind=r4_kind)) + dobj%i4missing_value = missing_value + type is (real(kind=i8_kind)) + dobj%i4missing_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 dobj%missing_value = DIAG_NULL endif From 70b7829480249bb29c44be6a81ad66cb970a8606 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Mon, 25 Oct 2021 09:35:51 -0400 Subject: [PATCH 007/142] Fixes typos in filling in missing value for diag object registration. --- diag_manager/fms_diag_object.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 5b3a52a957..8b7b83f2ab 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -248,11 +248,11 @@ subroutine fms_register_diag_field_obj & type is (integer(kind=i4_kind)) dobj%i4missing_value = missing_value type is (integer(kind=i8_kind)) - dobj%i4missing_value = missing_value + dobj%i8missing_value = missing_value type is (real(kind=r4_kind)) - dobj%i4missing_value = missing_value - type is (real(kind=i8_kind)) - dobj%i4missing_value = missing_value + dobj%r4missing_value = missing_value + type is (real(kind=r8_kind)) + dobj%r8missing_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",& From 3acef8f1be1cdbe21cb116c4008762ab6a6a214a Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Tue, 2 Nov 2021 11:47:40 -0400 Subject: [PATCH 008/142] Removes diag_object operator overrides. Fixes inquiry for diag_id Sets up diag_yaml_object --- diag_manager/fms_diag_object.F90 | 219 +++---------------------------- diag_manager/fms_diag_yaml.F90 | 42 +++++- 2 files changed, 56 insertions(+), 205 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 41d4756307..27da92a4cf 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -10,8 +10,9 @@ module fms_diag_object_mod use diag_data_mod, only: diag_null use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id +use diag_data_mod, only: diag_fields_type, diag_files_type use fms_diag_yaml_mod, only: is_field_type_null -use fms_diag_yaml_mod, only: diag_fields_type, diag_files_type, get_diag_table_field +use fms_diag_yaml_mod, only: diag_yaml use diag_axis_mod, only: diag_axis_type use mpp_mod, only: fatal, note, warning, mpp_error !use diag_util_mod, only: int_to_cs, logical_to_cs @@ -22,32 +23,6 @@ module fms_diag_object_mod implicit none -interface operator (<) - procedure obj_lt_int - procedure int_lt_obj -end interface -interface operator (<=) - procedure obj_le_int - procedure int_le_obj -end interface -interface operator (>) - procedure obj_gt_int - procedure int_gt_obj -end interface -interface operator (>=) - procedure obj_ge_int - procedure int_ge_obj -end interface -interface operator (==) - procedure obj_eq_int - procedure int_eq_obj -end interface -interface operator (.ne.) - procedure obj_ne_int - procedure int_ne_obj -end interface - - !> \brief Object that holds all variable information type fms_diag_object type (diag_fields_type) :: diag_field !< info from diag_table @@ -72,7 +47,8 @@ module fms_diag_object_mod contains ! procedure :: send_data => fms_send_data !!TODO procedure :: init_ob => diag_obj_init - procedure :: diag_id_inq => fms_diag_id_inq + procedure :: get_id => fms_diag_get_id + procedure :: id => fms_diag_get_id procedure :: copy => copy_diag_obj procedure :: register_meta => fms_register_diag_field_obj procedure :: setID => set_diag_id @@ -119,8 +95,7 @@ module fms_diag_object_mod !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d -public :: copy_diag_obj, fms_diag_id_inq -public :: operator (>),operator (<),operator (>=),operator (<=),operator (==),operator (.ne.) +public :: copy_diag_obj, fms_diag_get_id public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d public :: fms_diag_object_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -150,6 +125,7 @@ subroutine diag_obj_init(ob) select type (ob) class is (fms_diag_object) ob%diag_id = diag_not_registered !null_ob%diag_id + ob%registered = .false. end select end subroutine diag_obj_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -173,7 +149,8 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long allocate(character(len=len(modname)) :: dobj%modname) dobj%modname = trim(modname) !> Grab the information from the diag_table - dobj%diag_field = get_diag_table_field(trim(varname)) +! dobj%diag_field = get_diag_table_field(trim(varname)) +! dobj%diag_field = diag_yaml%get_diag_field( if (is_field_type_null(dobj%diag_field)) then dobj%diag_id = diag_not_found dobj%vartype = diag_null @@ -200,6 +177,8 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long ! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind ! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind +!> Set the registered flag to true + dobj%registered = .true. end subroutine fms_register_diag_field_obj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief Sets the diag_id. This can only be done if a variable is unregistered @@ -300,16 +279,19 @@ subroutine copy_diag_obj(objin , objout) end select end subroutine copy_diag_obj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \brief Returns the diag_id -integer function fms_diag_id_inq (dobj) result(diag_id) +!> \brief Returns the ID integer for a variable +integer function fms_diag_get_id (dobj) result(diag_id) class(fms_diag_object) , intent(inout) :: dobj ! character(*) , intent(in) :: varname - - if (.not.allocated(dobj%registered)) then - call mpp_error ("fms_what_is_my_id","The diag object was not registered", fatal) +!> 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 - diag_id = dobj%diag_id -end function fms_diag_id_inq +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: @@ -382,166 +364,5 @@ function diag_obj_get_varname(obj) result (rslt) rslt = obj%varname end function diag_obj_get_varname -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \brief override for checking if object ID is greater than an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_gt_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i >= diag_not_registered) then - ll = .false. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (obj%diag_id > i) - endif -end function obj_gt_int -!> \brief override for checking if integer (ID) is greater than an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_gt_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i <= diag_not_registered) then - ll = .false. - elseif (.not.allocated(obj)) then - ll = .true. - else - ll = (i > obj%diag_id) - endif -end function int_gt_obj -!> \brief override for checking if object ID is less than an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_lt_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i > diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj)) then - ll = .false. - else - ll = (obj%diag_id < i) - endif -end function obj_lt_int -!> \brief override for checking if integer (ID) is less than an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_lt_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i >= diag_not_registered) then - ll = .false. - elseif (.not.allocated(obj)) then - ll = .true. - else - ll = (i < obj%diag_id) - endif -end function int_lt_obj -!> \brief override for checking if object ID is greater than or equal to an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_ge_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i <= diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (obj%diag_id >= i) - endif -end function obj_ge_int -!> \brief override for checking if integer (ID) is greater than or equal to an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_ge_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i >= diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (i >= obj%diag_id) - endif -end function int_ge_obj -!> \brief override for checking if object ID is less than or equal to an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_le_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i >= diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (obj%diag_id <= i) - endif -end function obj_le_int -!> \brief override for checking if integer (ID) is less than or equal to an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_le_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i <= diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (i <= obj%diag_id) - endif -end function int_le_obj -!> \brief override for checking if object ID is equal to an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_eq_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i == diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (obj%diag_id == i) - endif -end function obj_eq_int -!> \brief override for checking if integer (ID) is equal to an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_eq_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i == diag_not_registered) then - ll = .true. - elseif (.not.allocated(obj) ) then - ll = .false. - else - ll = (i == obj%diag_id) - endif -end function int_eq_obj - -!> \brief override for checking if object ID is not equal to an integer (IDs) -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function obj_ne_int (obj,i) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i == diag_not_registered) then - ll = .false. - elseif (.not.allocated(obj) ) then - ll = .true. - else - ll = (obj%diag_id .ne. i) - endif -end function obj_ne_int - -!> \brief override for checking if integer (ID) is not equal to an object ID -!> @note unalloacted obj is assumed to equal diag_not_registered -pure logical function int_ne_obj (i,obj) result(ll) - class (fms_diag_object), intent(in), allocatable :: obj - integer, intent(in) :: i - if (.not.allocated(obj) .and. i == diag_not_registered) then - ll = .false. - elseif (.not.allocated(obj) ) then - ll = .true. - else - ll = (i .ne. obj%diag_id) - endif -end function int_ne_obj end module fms_diag_object_mod diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index f96c50ac84..41c2777435 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -2,19 +2,49 @@ module fms_diag_yaml_mod use diag_data_mod, only: diag_files_type, diag_fields_type +integer, parameter :: basedate_size = 7 + +!> Object that holds the information of the diag_yaml +type diag_yaml_object + character(len=:), allocatable, private :: diag_title !< Experiment name + integer, private, dimension (basedate_size) :: diag_basedate !< basedate array + type(diag_files_type), allocatable, private, dimension (:) :: diag_files!< History file info + type(diag_fields_type), allocatable, private, dimension (:,:) :: diag_fields !< Diag fields info + contains + procedure :: title => get_title !< Returns the title + procedure :: basedate => get_basedate !< Returns the basedate array +end type diag_yaml_object +type (diag_yaml_object) :: diag_yaml + +public :: get_title, get_basedate + contains + +!> \brief Returns the basedate as an integer array +pure function get_basedate (diag_yaml) result (diag_basedate) +class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml +integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return +diag_basedate = diag_yaml%diag_basedate +end function get_basedate +!> \brief Returns the title of the diag table as an allocated string +pure function get_title (diag_yaml) result (diag_title) +class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml +character(len=:),allocatable :: diag_title !< Basedate array result to return + diag_title = diag_yaml%diag_title +end function get_title + !> \brief Compares two field type variables pure logical function is_field_type_null (in1) type(diag_fields_type), intent(in) :: in1 -is_field_type_null = (in1%ikind == DIAG_NULL) +is_field_type_null = .true. end function is_field_type_null !!TODO !> \brief looks for a diag_field based on it's name. !! Returns null if field is not found. -type(diag_fields_type)function get_diag_table_field (field_name) result (field) - character(len=*), intent(IN) :: field_name - integer :: i +!type(diag_fields_type)function get_diag_table_field (field_name) result (field) +! character(len=*), intent(IN) :: field_name +! integer :: i ! do i = 1,size(diag_fields) ! if (trim(field_name) == trim(fms_c2f_string(diag_fields(i)%fname))) then ! field = diag_fields(i) @@ -24,8 +54,8 @@ end function is_field_type_null ! endif ! enddo ! field = null_field_type - -end function get_diag_table_field +! +!end function get_diag_table_field From e24ccfdcf192156a5489325ad16fe8e7d5ad106a Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 3 Nov 2021 13:05:31 -0400 Subject: [PATCH 009/142] Initial add of fms_diag_yaml_object.F90 --- diag_manager/Makefile.am | 4 +- diag_manager/fms_diag_yaml_object.F90 | 374 ++++++++++++++++++++++++++ 2 files changed, 377 insertions(+), 1 deletion(-) create mode 100644 diag_manager/fms_diag_yaml_object.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 50ff238366..076bdc8f71 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -41,7 +41,8 @@ libdiag_manager_la_SOURCES = \ fms_diag_yaml.F90 \ diag_yaml.h \ diag_yaml.c \ - fms_diag_object.F90 + fms_diag_object.F90 \ + fms_diag_yaml_object.F90 # Some mods are dependant on other mods in this dir. diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) @@ -63,6 +64,7 @@ MODFILES = \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ + fms_diag_yaml_object_mod.$(FC_MODEXT) \ fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_object_mod.$(FC_MODEXT) \ diag_manager_mod.$(FC_MODEXT) diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90 new file mode 100644 index 0000000000..4bb242d4eb --- /dev/null +++ b/diag_manager/fms_diag_yaml_object.F90 @@ -0,0 +1,374 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +!> @defgroup fms_diag_yaml_object_mod fms_diag_yaml_object_mod +!> @ingroup diag_manager +!! @brief The diag yaml objects are handled here, with variables the correspond to +!! entries in the diag yaml file. The actual parsing of the yaml is handled in +!! @ref fms_diag_yaml_mod. +!! @author Tom Robinson + +!> @file +!> @brief File for @ref fms_diag_yaml_object_mod + +!> @addtogroup fms_diag_yaml_object_mod +!> @{ +module fms_diag_yaml_object_mod + +use fms_mod , only: fms_c2f_string +use iso_c_binding + implicit none +integer, parameter :: NUM_REGION_ARRAY = 8 + !> @brief The files type matching a C struct containing diag_yaml information + !> @ingroup fms_diag_files_mod +type, bind(c) :: diag_yaml_files_struct + character (kind=c_char) :: file_fname (20) !< file name + character (kind=c_char) :: file_frequnit (7) !< the frequency unit + integer (c_int) :: file_freq !< the frequency of data + character (kind=c_char) :: file_timeunit(7) !< The unit of time + character (kind=c_char) :: file_unlimdim(8) !< The name of the unlimited dimension + character (kind=c_char) :: file_write (5) !< false if the user doesn’t want the file to be + !! created (default is true). + character (kind=c_char) :: file_realm (3) !< The modeling realm that the variables come from + real (c_float) :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture + integer (c_int) :: file_new_file_freq !< Frequency for closing the existing file + character (kind=c_char) :: file_new_file_freq_units (3)!< Time units for creating a new file. + !! Required if “new_file_freq” used + integer (c_int) :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq” + integer (c_int) :: file_duration !< How long the file should receive data after start time + !! in “file_duration_units”.  This optional field can only + !! be used if the start_time field is present.  If this field + !! is absent, then the file duration will be equal to the + !! frequency for creating new files.  + !! NOTE: The file_duration_units field must also be present if + !! this field is present. + character (kind=c_char) :: file_duration_units (3)!< The file duration units +end type diag_yaml_files_struct + +type diag_yaml_files_type + character (len=:), allocatable :: file_fname !< file name + character (len=:), allocatable :: file_frequnit !< the frequency unit + integer (c_int) :: file_freq !< the frequency of data + character (len=:), allocatable :: file_timeunit !< The unit of time + character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension + logical :: file_write + character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be + !! created (default is true). + character (len=:), allocatable :: file_realm !< The modeling realm that the variables come from + real :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture + integer :: file_new_file_freq !< Frequency for closing the existing file + character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file. + !! Required if “new_file_freq” used + integer :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq” + integer :: file_duration !< How long the file should receive data after start time + !! in “file_duration_units”.  This optional field can only + !! be used if the start_time field is present.  If this field + !! is absent, then the file duration will be equal to the + !! frequency for creating new files.  + !! NOTE: The file_duration_units field must also be present if + !! this field is present. + character (len=:), allocatable :: file_duration_units !< The file duration units + character (len=:), dimension(:), allocatable :: file_varlist !< An array of variable names + !! within a file + character (len=:), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1) + !! and values(dim=2) to be added as global + !! meta data to the file + + contains + procedure :: copy_struct => copy_file_struct_to_object + procedure :: fname => get_file_fname + procedure :: frequnit => get_file_frequnit + procedure :: freq => get_file_freq + procedure :: timeunit => get_file_timeunit + procedure :: unlimdim => get_file_unlimdim + procedure :: write_file => get_file_write + procedure :: realm => get_file_realm + procedure :: region => get_file_region + procedure :: new_file_freq => get_file_new_file_freq + procedure :: new_file_freq_units => get_file_new_file_freq_units + procedure :: start_time => get_file_start_time + procedure :: duration => get_file_duration + procedure :: duration_units => get_file_duration_units + procedure :: varlist => get_file_varlist + procedure :: global_meta => get_file_global_meta + +end type diag_yaml_files_type + +!> @brief The field type matching the C struct for diag_yaml information + !> @ingroup fms_diag_files_mod +type, bind(c) :: diag_yaml_files_var_struct + character (kind=c_char) :: var_fname (20) !< The field/diagnostic name + character (kind=c_char) :: var_varname(20) !< The name of the variable + character (kind=c_char) :: var_reduction(20) !< Reduction to be done on var + character (kind=c_char) :: var_module(20) !< The module that th variable is in + character (kind=c_char) :: var_skind(8) !< The type/kind of the variable + character (kind=c_char) :: var_write(5) !< false if the user doesn’t want the variable to be + !! written to the file (default: true). + character (kind=c_char) :: var_outname(20) !< Name of the variable as written to the file + character (kind=c_char) :: var_longname(100) !< Overwrites the long name of the variable + character (kind=c_char) :: var_units(10) !< Overwrites the units +end type diag_yaml_files_var_struct + +type diag_yaml_files_var_type + character (len=:), allocatable :: var_fname !< The field/diagnostic name + character (len=:), allocatable :: var_varname !< The name of the variable + character (len=:), allocatable :: var_reduction !< Reduction to be done on var + character (len=:), allocatable :: var_module !< The module that th variable is in + character (len=:), allocatable :: var_skind !< The type/kind of the variable + character (len=:), allocatable :: string_var_write !< false if the user doesn’t want the variable to be + !! written to the file (default: true). + logical :: var_write !< false if the user doesn’t want the variable to be + !! written to the file (default: true). + character (len=:), allocatable :: var_outname !< Name of the variable as written to the file + character (len=:), allocatable :: var_longname !< Overwrites the long name of the variable + character (len=:), allocatable :: var_units !< Overwrites the units + character (len=:), dimension (:), allocatable :: var_attributes !< Attributes to overwrite or + !! add from diag_yaml + contains + procedure :: copy_struct => copy_variable_struct_to_object + procedure :: fname => get_var_fname + procedure :: varname => get_var_varname + procedure :: reduction => get_var_reduction + procedure :: module_var => get_var_module + procedure :: skind => get_var_skind + procedure :: outname => get_var_outname + procedure :: longname => get_var_longname + procedure :: units => get_var_units + procedure :: write_var => get_var_write + procedure :: attr => get_var_attributes + +end type diag_yaml_files_var_type + +contains +!!!!!!!! YAML FILE ROUTINES !!!!!!!! +!< \brief Copies the information of the yaml struct to the fortran object holding the info +subroutine copy_file_struct_to_object(diag_files_obj, diag_files_struct) + class(diag_yaml_files_type) :: diag_files_obj !< Fortran-side object with diag_yaml info + type(diag_yaml_files_struct) :: diag_files_struct !< The C struct that has the diag_yaml + !! info + integer :: i !< For looping +!< Convert the C strings to Fortran strings + diag_files_obj%file_fname = fms_c2f_string (diag_files_struct%file_fname) + diag_files_obj%file_frequnit = fms_c2f_string (diag_files_struct%file_frequnit) + diag_files_obj%file_timeunit = fms_c2f_string (diag_files_struct%file_timeunit) + diag_files_obj%file_unlimdim = fms_c2f_string (diag_files_struct%file_unlimdim) + diag_files_obj%file_realm = fms_c2f_string (diag_files_struct%file_realm) + diag_files_obj%file_new_file_freq_units = fms_c2f_string (diag_files_struct%file_new_file_freq_units) + diag_files_obj%file_duration_units = fms_c2f_string (diag_files_struct%file_duration_units) +!< Set the file_write to be true or false + diag_files_obj%string_file_write = fms_c2f_string (diag_files_struct%file_write) + diag_files_obj%file_write = .true. + if (diag_files_obj%string_file_write(1:1)=="f" .or. & + diag_files_obj%string_file_write(1:1)=="F") & + diag_files_obj%file_write = .false. + deallocate (diag_files_obj%string_file_write) +!< Store the numbers + diag_files_obj%file_freq = diag_files_struct%file_freq +!$omp simd + do i = 1, NUM_REGION_ARRAY + diag_files_obj%file_region(i) = diag_files_struct%file_region(i) + enddo + diag_files_obj%file_new_file_freq = diag_files_struct%file_new_file_freq + diag_files_obj%file_start_time = diag_files_struct%file_start_time + diag_files_obj%file_duration = diag_files_struct%file_duration + +end subroutine copy_file_struct_to_object +!!!!!!! YAML FILE INQUIRIES !!!!!!! +!> \brief Inquiry for diag_files_obj%file_fname +pure function get_file_fname (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_files_obj%file_fname +end function get_file_fname +!> \brief Inquiry for diag_files_obj%file_frequnit +pure function get_file_frequnit (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_files_obj%file_frequnit +end function get_file_frequnit +!> \brief Inquiry for diag_files_obj%file_freq +pure function get_file_freq(diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_freq +end function get_file_freq +!> \brief Inquiry for diag_files_obj%file_timeunit +pure function get_file_timeunit (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_files_obj%file_timeunit +end function get_file_timeunit +!> \brief Inquiry for diag_files_obj%file_unlimdim +pure function get_file_unlimdim(diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_files_obj%file_unlimdim +end function get_file_unlimdim +!> \brief Inquiry for diag_files_obj%file_write +pure function get_file_write(diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + logical :: res !< What is returned + res = diag_files_obj%file_write +end function get_file_write +!> \brief Inquiry for diag_files_obj%file_realm +pure function get_file_realm(diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (*) :: res !< What is returned + res = diag_files_obj%file_realm +end function get_file_realm +!> \brief Inquiry for diag_files_obj%file_region +pure function get_file_region (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + real :: res (NUM_REGION_ARRAY) !< What is returned + res = diag_files_obj%file_region +end function get_file_region +!> \brief Inquiry for diag_files_obj%file_new_file_freq +pure function get_file_new_file_freq(diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_new_file_freq +end function get_file_new_file_freq +!> \brief Inquiry for diag_files_obj%file_new_file_freq_units +pure function get_file_new_file_freq_units (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (*) :: res !< What is returned + res = diag_files_obj%file_new_file_freq_units +end function get_file_new_file_freq_units +!> \brief Inquiry for diag_files_obj%file_start_time +pure function get_file_start_time (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_start_time +end function get_file_start_time +!> \brief Inquiry for diag_files_obj%file_duration +pure function get_file_duration (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_duration +end function get_file_duration +!> \brief Inquiry for diag_files_obj%file_duration_units +pure function get_file_duration_units (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (*) :: res !< What is returned + res = diag_files_obj%file_duration_units +end function get_file_duration_units +!> \brief Inquiry for diag_files_obj%file_varlist +pure function get_file_varlist (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (*) :: res(:) !< What is returned + res = diag_files_obj%file_varlist +end function get_file_varlist +!> \brief Inquiry for diag_files_obj%file_global_meta +pure function get_file_global_meta (diag_files_obj) result (res) + class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + character (*) :: res(:,:) !< What is returned + res = diag_files_obj%file_global_meta +end function get_file_global_meta +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!! +!< \brief Copies the information of the yaml struct to the fortran object holding the var info +subroutine copy_variable_struct_to_object(diag_var_obj, diag_var_struct) + class(diag_yaml_files_var_type) :: diag_var_obj !< Fortran-side object with diag_yaml var info + type(diag_yaml_files_var_struct) :: diag_var_struct !< The C struct that has the diag_yaml + !! var info +!< Convert the C strings to Fortran strings + diag_var_obj%var_fname = fms_c2f_string (diag_var_struct%var_fname) + diag_var_obj%var_varname = fms_c2f_string (diag_var_struct%var_varname) + diag_var_obj%var_reduction = fms_c2f_string (diag_var_struct%var_reduction) + diag_var_obj%var_module = fms_c2f_string (diag_var_struct%var_module) + diag_var_obj%var_skind = fms_c2f_string (diag_var_struct%var_skind) + diag_var_obj%var_outname = fms_c2f_string (diag_var_struct%var_outname) + diag_var_obj%var_longname = fms_c2f_string (diag_var_struct%var_longname) + diag_var_obj%var_units = fms_c2f_string (diag_var_struct%var_units) +!< Set the file_write to be true or false + diag_var_obj%string_var_write= fms_c2f_string (diag_var_struct%var_write) + diag_var_obj%var_write= .true. + if (diag_var_obj%string_var_write(1:1)=="f" .or. & + diag_var_obj%string_var_write(1:1)=="F") & + diag_var_obj%var_write= .false. + deallocate (diag_var_obj%string_var_write) +end subroutine copy_variable_struct_to_object +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!! YAML VAR INQUIRIES !!!!!!! +!> \brief Inquiry for diag_yaml_files_var_obj%var_fname +pure function get_var_fname (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_objn%var_fname +end function get_var_fname +!> \brief Inquiry for diag_yaml_files_var_obj%var_varname +pure function get_var_varname (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_varname +end function get_var_varname +!> \brief Inquiry for diag_yaml_files_var_obj%var_reduction +pure function get_var_reduction (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_reduction +end function get_var_reduction +!> \brief Inquiry for diag_yaml_files_var_obj%var_module +pure function get_var_module (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_module +end function get_var_module +!> \brief Inquiry for diag_yaml_files_var_obj%var_skind +pure function get_var_skind (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_skind +end function get_var_skind +!> \brief Inquiry for diag_yaml_files_var_obj%var_outname +pure function get_var_outname (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_outname +end function get_var_outname +!> \brief Inquiry for diag_yaml_files_var_obj%var_longname +pure function get_var_longname (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_longname +end function get_var_longname +!> \brief Inquiry for diag_yaml_files_var_obj%var_units +pure function get_var_units (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res !< What is returned + res = diag_var_obj%var_units +end function get_var_units +!> \brief Inquiry for diag_yaml_files_var_obj%var_write +pure function get_var_write (diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + logical :: res !< What is returned + res = diag_var_obj%var_write +end function get_var_write +!> \brief Inquiry for diag_yaml_files_var_obj%var_attributes +pure function get_var_attributes(diag_var_obj) result (res) + class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=*) :: res (:) !< What is returned + res = diag_var_obj%var_attributes +end function get_var_attributes + +end module fms_diag_yaml_object_mod +!> @} +! close documentation grouping + From 00988c14ec8da662515a673a05c1278bd560d8ed Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 10 Nov 2021 09:29:12 -0500 Subject: [PATCH 010/142] Updates fms_c2f_string to convert C-string and C-pointers to a Fortran string --- fms/fms.F90 | 17 ++++++++++++++--- test_fms/fms/test_fms.F90 | 2 +- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/fms/fms.F90 b/fms/fms.F90 index ff8beca362..c096e1a887 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -300,6 +300,10 @@ module fms_mod module procedure string_from_integer module procedure string_from_real end interface +interface fms_c2f_string + module procedure cstring_fortran_conversion + module procedure cpointer_fortran_conversion +end interface !> C functions interface !> @brief converts a kind=c_char to type c_ptr @@ -820,10 +824,17 @@ function string_from_real(a) end function string_from_real +!> \brief Converts a C-string to a pointer and then to a Fortran string +pure function cstring_fortran_conversion (cstring) result(fstring) + character (kind=c_char), intent(in) :: cstring (*) !< Input C-string + character(len=:), allocatable :: fstring !< The fortran string returned + fstring = cpointer_fortran_conversion(fms_cstring2cpointer(cstring)) +end function cstring_fortran_conversion + !> \brief Converts a C-string returned from a TYPE(C_PTR) function to !! a fortran string with type character. -function fms_c2f_string (cstring) result(fstring) - type (c_ptr) :: cstring +pure function cpointer_fortran_conversion (cstring) result(fstring) + type (c_ptr), intent(in) :: cstring !< Input C-pointer character(len=:), allocatable :: fstring !< The fortran string returned character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran integer(c_size_t) :: length !< The string length @@ -840,7 +851,7 @@ function fms_c2f_string (cstring) result(fstring) allocate(character(len=length) :: fstring) !> Set the length of fstring fstring = string_buffer -end function fms_c2f_string +end function cpointer_fortran_conversion !####################################################################### !> @brief Prints to the log file (or a specified unit) the version id string and !! tag name. diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index bdb3d39e75..91740f057a 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -62,7 +62,7 @@ program test_fms Cstring(17) = c_null_char call mpp_error(NOTE,"Testing fms_cstring2cpointer and fms_c2f_string") ! test = fms_c2f_string(fms_cstring2cpointer(c_char_"100 "//c_null_char)) - test = fms_c2f_string(fms_cstring2cpointer(Cstring)) + test = fms_c2f_string(Cstring) if (trim(answer) .eq. trim(test)) then call mpp_error(NOTE, trim(test)//" matches "//trim(answer)) else From fd8e98b02139173abf2c5290887aef0dd837de52 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Wed, 10 Nov 2021 09:36:18 -0500 Subject: [PATCH 011/142] Removes pure functionality for string conversions --- fms/fms.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/fms/fms.F90 b/fms/fms.F90 index c096e1a887..330176a64c 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -825,7 +825,7 @@ function string_from_real(a) end function string_from_real !> \brief Converts a C-string to a pointer and then to a Fortran string -pure function cstring_fortran_conversion (cstring) result(fstring) +function cstring_fortran_conversion (cstring) result(fstring) character (kind=c_char), intent(in) :: cstring (*) !< Input C-string character(len=:), allocatable :: fstring !< The fortran string returned fstring = cpointer_fortran_conversion(fms_cstring2cpointer(cstring)) @@ -833,7 +833,7 @@ end function cstring_fortran_conversion !> \brief Converts a C-string returned from a TYPE(C_PTR) function to !! a fortran string with type character. -pure function cpointer_fortran_conversion (cstring) result(fstring) +function cpointer_fortran_conversion (cstring) result(fstring) type (c_ptr), intent(in) :: cstring !< Input C-pointer character(len=:), allocatable :: fstring !< The fortran string returned character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran From 67e1e962b8c619d6a3365a29e4b146b5beaee016 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Thu, 11 Nov 2021 08:06:00 -0500 Subject: [PATCH 012/142] Fixes compile errors in new diag manager related to objects --- diag_manager/fms_diag_object.F90 | 2 +- diag_manager/fms_diag_yaml_object.F90 | 38 +++++++++++++-------------- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index eb0abcc1e9..2885da0cb5 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -78,7 +78,7 @@ module fms_diag_object_mod procedure :: get_id => fms_diag_get_id procedure :: id => fms_diag_get_id procedure :: copy => copy_diag_obj - procedure :: register_meta => fms_register_diag_field_obj + procedure :: register => fms_register_diag_field_obj procedure :: setID => set_diag_id procedure :: is_registered => diag_ob_registered procedure :: set_type => set_vartype diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90 index 4bb242d4eb..4ac308758a 100644 --- a/diag_manager/fms_diag_yaml_object.F90 +++ b/diag_manager/fms_diag_yaml_object.F90 @@ -192,13 +192,13 @@ end subroutine copy_file_struct_to_object !> \brief Inquiry for diag_files_obj%file_fname pure function get_file_fname (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_fname end function get_file_fname !> \brief Inquiry for diag_files_obj%file_frequnit pure function get_file_frequnit (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_frequnit end function get_file_frequnit !> \brief Inquiry for diag_files_obj%file_freq @@ -210,13 +210,13 @@ end function get_file_freq !> \brief Inquiry for diag_files_obj%file_timeunit pure function get_file_timeunit (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_timeunit end function get_file_timeunit !> \brief Inquiry for diag_files_obj%file_unlimdim pure function get_file_unlimdim(diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_unlimdim end function get_file_unlimdim !> \brief Inquiry for diag_files_obj%file_write @@ -228,7 +228,7 @@ end function get_file_write !> \brief Inquiry for diag_files_obj%file_realm pure function get_file_realm(diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (*) :: res !< What is returned + character (:), allocatable :: res !< What is returned res = diag_files_obj%file_realm end function get_file_realm !> \brief Inquiry for diag_files_obj%file_region @@ -246,7 +246,7 @@ end function get_file_new_file_freq !> \brief Inquiry for diag_files_obj%file_new_file_freq_units pure function get_file_new_file_freq_units (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (*) :: res !< What is returned + character (:), allocatable :: res !< What is returned res = diag_files_obj%file_new_file_freq_units end function get_file_new_file_freq_units !> \brief Inquiry for diag_files_obj%file_start_time @@ -264,19 +264,19 @@ end function get_file_duration !> \brief Inquiry for diag_files_obj%file_duration_units pure function get_file_duration_units (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (*) :: res !< What is returned + character (:), allocatable :: res !< What is returned res = diag_files_obj%file_duration_units end function get_file_duration_units !> \brief Inquiry for diag_files_obj%file_varlist pure function get_file_varlist (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (*) :: res(:) !< What is returned + character (:), allocatable :: res(:) !< What is returned res = diag_files_obj%file_varlist end function get_file_varlist !> \brief Inquiry for diag_files_obj%file_global_meta pure function get_file_global_meta (diag_files_obj) result (res) class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - character (*) :: res(:,:) !< What is returned + character (:), allocatable :: res(:,:) !< What is returned res = diag_files_obj%file_global_meta end function get_file_global_meta !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -310,49 +310,49 @@ end subroutine copy_variable_struct_to_object !> \brief Inquiry for diag_yaml_files_var_obj%var_fname pure function get_var_fname (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned - res = diag_var_objn%var_fname + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_fname end function get_var_fname !> \brief Inquiry for diag_yaml_files_var_obj%var_varname pure function get_var_varname (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_varname end function get_var_varname !> \brief Inquiry for diag_yaml_files_var_obj%var_reduction pure function get_var_reduction (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_reduction end function get_var_reduction !> \brief Inquiry for diag_yaml_files_var_obj%var_module pure function get_var_module (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_module end function get_var_module !> \brief Inquiry for diag_yaml_files_var_obj%var_skind pure function get_var_skind (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_skind end function get_var_skind !> \brief Inquiry for diag_yaml_files_var_obj%var_outname pure function get_var_outname (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_outname end function get_var_outname !> \brief Inquiry for diag_yaml_files_var_obj%var_longname pure function get_var_longname (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_longname end function get_var_longname !> \brief Inquiry for diag_yaml_files_var_obj%var_units pure function get_var_units (diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res !< What is returned + character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_units end function get_var_units !> \brief Inquiry for diag_yaml_files_var_obj%var_write @@ -364,7 +364,7 @@ end function get_var_write !> \brief Inquiry for diag_yaml_files_var_obj%var_attributes pure function get_var_attributes(diag_var_obj) result (res) class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=*) :: res (:) !< What is returned + character (len=:), allocatable :: res (:) !< What is returned res = diag_var_obj%var_attributes end function get_var_attributes From 1c2ba1721410646165f28ee152d17ee8dcb1cb27 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Mon, 15 Nov 2021 10:43:04 -0500 Subject: [PATCH 013/142] Updates doxygen on string conversion interface Memory clean up in string conversion function --- fms/fms.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/fms/fms.F90 b/fms/fms.F90 index 330176a64c..6552575268 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -300,6 +300,8 @@ module fms_mod module procedure string_from_integer module procedure string_from_real end interface +!> Converts a C string to a Fortran string +!> @ingroup fms_mod interface fms_c2f_string module procedure cstring_fortran_conversion module procedure cpointer_fortran_conversion @@ -850,7 +852,7 @@ function cpointer_fortran_conversion (cstring) result(fstring) allocate(character(len=length) :: fstring) !> Set the length of fstring fstring = string_buffer - + deallocate(string_buffer) end function cpointer_fortran_conversion !####################################################################### !> @brief Prints to the log file (or a specified unit) the version id string and From 440f58e488713e259f80e2a497c068ba6b1aadc9 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Mon, 29 Nov 2021 14:39:01 -0500 Subject: [PATCH 014/142] Updates get functions in the diag yaml objects --- diag_manager/fms_diag_yaml_object.F90 | 50 +++++++++++++-------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90 index 4ac308758a..b26a4a3bdc 100644 --- a/diag_manager/fms_diag_yaml_object.F90 +++ b/diag_manager/fms_diag_yaml_object.F90 @@ -91,21 +91,21 @@ module fms_diag_yaml_object_mod contains procedure :: copy_struct => copy_file_struct_to_object - procedure :: fname => get_file_fname - procedure :: frequnit => get_file_frequnit - procedure :: freq => get_file_freq - procedure :: timeunit => get_file_timeunit - procedure :: unlimdim => get_file_unlimdim - procedure :: write_file => get_file_write - procedure :: realm => get_file_realm - procedure :: region => get_file_region - procedure :: new_file_freq => get_file_new_file_freq - procedure :: new_file_freq_units => get_file_new_file_freq_units - procedure :: start_time => get_file_start_time - procedure :: duration => get_file_duration - procedure :: duration_units => get_file_duration_units - procedure :: varlist => get_file_varlist - procedure :: global_meta => get_file_global_meta + procedure :: get_file_fname + procedure :: get_file_frequnit + procedure :: get_file_freq + procedure :: get_file_timeunit + procedure :: get_file_unlimdim + procedure :: get_file_write + procedure :: get_file_realm + procedure :: get_file_region + procedure :: get_file_new_file_freq + procedure :: get_file_new_file_freq_units + procedure :: get_file_start_time + procedure :: get_file_duration + procedure :: get_file_duration_units + procedure :: get_file_varlist + procedure :: get_file_global_meta end type diag_yaml_files_type @@ -141,16 +141,16 @@ module fms_diag_yaml_object_mod !! add from diag_yaml contains procedure :: copy_struct => copy_variable_struct_to_object - procedure :: fname => get_var_fname - procedure :: varname => get_var_varname - procedure :: reduction => get_var_reduction - procedure :: module_var => get_var_module - procedure :: skind => get_var_skind - procedure :: outname => get_var_outname - procedure :: longname => get_var_longname - procedure :: units => get_var_units - procedure :: write_var => get_var_write - procedure :: attr => get_var_attributes + procedure :: get_var_fname + procedure :: get_var_varname + procedure :: get_var_reduction + procedure :: get_var_module + procedure :: get_var_skind + procedure :: get_var_outname + procedure :: get_var_longname + procedure :: get_var_units + procedure :: get_var_write + procedure :: get_var_attributes end type diag_yaml_files_var_type From 9f261fa4bc69f8b67bd493342b85b180c06ef1c9 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Tue, 28 Dec 2021 14:49:53 -0500 Subject: [PATCH 015/142] diag_yaml addition (#866) * initial changes for yaml parsing * Finishes reading the diag yaml file using the yaml parser * add a deconstructor, adds documentation and fixes style * reintroduces the diag_yaml objs to the diag_yaml type * Removes the dump_diag_yaml function * replaces all the 'regions' to 'sub_region', replaces x/y/z/u with dim1,2,3,4 when setting the subregion, label do loops, removes hardcodded string lengths in types * CMake update * fixes(?) the set subregional subroutines * more style changes + some error checking * update types name to camel * makes sub_regions allocatables, adds comment * fix alignment issues --- CMakeLists.txt | 3 + diag_manager/Makefile.am | 14 +- diag_manager/diag_data.F90 | 27 -- diag_manager/diag_manager.F90 | 11 + diag_manager/diag_yaml.c | 6 - diag_manager/diag_yaml.h | 28 --- diag_manager/fms_diag_object.F90 | 19 +- diag_manager/fms_diag_yaml.F90 | 347 ++++++++++++++++++++++---- diag_manager/fms_diag_yaml_object.F90 | 308 ++++++++++------------- 9 files changed, 467 insertions(+), 296 deletions(-) delete mode 100644 diag_manager/diag_yaml.c delete mode 100644 diag_manager/diag_yaml.h diff --git a/CMakeLists.txt b/CMakeLists.txt index c384aca4df..58e27d7c53 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -113,6 +113,9 @@ list(APPEND fms_fortran_src_files diag_manager/diag_output.F90 diag_manager/diag_table.F90 diag_manager/diag_util.F90 + diag_manager/fms_diag_object.F90 + diag_manager/fms_diag_yaml.F90 + diag_manager/fms_diag_yaml_object.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 076bdc8f71..19adddf346 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -39,22 +39,22 @@ libdiag_manager_la_SOURCES = \ diag_table.F90 \ diag_util.F90 \ fms_diag_yaml.F90 \ - diag_yaml.h \ - diag_yaml.c \ fms_diag_object.F90 \ fms_diag_yaml_object.F90 # Some mods are dependant on other mods in this dir. diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) -diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) \ - diag_yaml.h +diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_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) diag_yaml.h -fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) diag_yaml.h +fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ + fms_diag_yaml_object_mod.$(FC_MODEXT) +fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) \ + fms_diag_yaml_object_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ - fms_diag_object_mod.$(FC_MODEXT) + fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index deb1eb39bb..a2726de407 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -107,33 +107,6 @@ MODULE diag_data_mod !> @} - - !> @brief The files type matching a C struct containing diag_yaml information - !> @ingroup diag_data_mod -type, bind(c) :: diag_files_type - character (kind=c_char) :: fname (20) !< file name - character (kind=c_char) :: frequnit (7) !< the frequency unit - integer (c_int) :: freq !< the frequency of data - character (kind=c_char) :: timeunit(7) !< The unit of time - character (kind=c_char) :: unlimdim(8) !< The name of the unlimited dimension - character (kind=c_char) :: key(8) !< Storage for the key in the yaml file -end type diag_files_type -!> @brief The field type matching the C struct for diag_yaml information - !> @ingroup diag_data_mod -type, bind(c) :: diag_fields_type - character (kind=c_char) :: fname (20) !< The field/diagnostic name - character (kind=c_char) :: var(20) !< The name of the variable - character (kind=c_char) :: files(20) !< The files that the diagnostic will be written to - integer (c_int) :: ikind !< The type/kind of the variable - character (kind=c_char) :: skind(20) !< The type/kind of the variable - character (kind=c_char) :: reduction(20) !< IDK - character (kind=c_char) :: all_all(4) !< This has to be "all" - character (kind=c_char) :: region(50) !< The region - character (kind=c_char) :: regcoord(50) !< Coodinates of the region - character (kind=c_char) :: module_location(20) !< The module - character (kind=c_char) :: key(8) !< Storage for the key in the yaml file -end type diag_fields_type - !> @brief Contains the coordinates of the local domain to output. !> @ingroup diag_data_mod TYPE diag_grid diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 8a8c2cf963..09d4c80e3f 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -225,6 +225,9 @@ 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 +#ifdef use_yaml + use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end +#endif USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder USE constants_mod, ONLY: SECONDS_PER_DAY @@ -3470,6 +3473,10 @@ SUBROUTINE diag_manager_end(time) if (allocated(fileobj)) deallocate(fileobj) if (allocated(fileobjND)) deallocate(fileobjND) if (allocated(fnum_for_domain)) deallocate(fnum_for_domain) + +#ifdef use_yaml + if (use_modern_diag) call diag_yaml_object_end +#endif END SUBROUTINE diag_manager_end !> @brief Replaces diag_manager_end; close just one file: files(file) @@ -3685,6 +3692,10 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) END IF END IF +#ifdef use_yaml + if (use_modern_diag) CALL diag_yaml_object_init() +#endif + CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local) IF ( mystat /= 0 ) THEN IF ( fms_error_handler('diag_manager_mod::diag_manager_init',& diff --git a/diag_manager/diag_yaml.c b/diag_manager/diag_yaml.c deleted file mode 100644 index 29100fd997..0000000000 --- a/diag_manager/diag_yaml.c +++ /dev/null @@ -1,6 +0,0 @@ -/** #include **/ -#include -#include -#include -/** #include **/ - diff --git a/diag_manager/diag_yaml.h b/diag_manager/diag_yaml.h deleted file mode 100644 index fe1c9212ed..0000000000 --- a/diag_manager/diag_yaml.h +++ /dev/null @@ -1,28 +0,0 @@ -#include -#include -#include -#include -typedef struct diag_files { - char name [20]; - char frequnit [7]; - int freq; - char timeunit [7]; - char unlimdim [8]; - char key [8]; -} files; - - -typedef struct diag_fields { - char name[20]; - char var[20]; - char files[20]; - int intkind; - char skind[20]; - char reduction[20]; - char all[4]; - char region[50]; - char regcoord[50]; - char module[20]; - char key [8]; -} fields; - diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 2885da0cb5..a07b50ba05 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -10,11 +10,9 @@ module fms_diag_object_mod use diag_data_mod, only: diag_null use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id -use diag_data_mod, only: diag_fields_type, diag_files_type -use fms_diag_yaml_mod, only: is_field_type_null -use fms_diag_yaml_mod, only: diag_yaml use diag_axis_mod, only: diag_axis_type use mpp_mod, only: fatal, note, warning, mpp_error +use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_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, & @@ -31,8 +29,8 @@ module fms_diag_object_mod !> \brief Object that holds all variable information type fms_diag_object - type (diag_fields_type) :: diag_field !< info from diag_table - type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table + type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table + type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table integer, allocatable, private :: diag_id !< unique id for varable class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the !! file objects for this variable @@ -194,13 +192,14 @@ subroutine fms_register_diag_field_obj & allocate(character(len=len(modname)) :: dobj%modname) dobj%modname = trim(modname) !> Grab the information from the diag_table +! TO DO: ! dobj%diag_field = get_diag_table_field(trim(varname)) ! dobj%diag_field = diag_yaml%get_diag_field( - if (is_field_type_null(dobj%diag_field)) then - dobj%diag_id = diag_not_found - dobj%vartype = diag_null - return - endif +! if (is_field_type_null(dobj%diag_field)) then +! dobj%diag_id = diag_not_found +! dobj%vartype = diag_null +! return +! endif !> get the optional arguments if included and the diagnostic is in the diag table if (present(longname)) then allocate(character(len=len(longname)) :: dobj%longname) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 41c2777435..9a423697e0 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -1,62 +1,319 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @defgroup fms_diag_yaml_mod fms_diag_yaml_mod +!> @ingroup diag_manager +!! @brief fms_diag_yaml_mod is an integral part of +!! diag_manager_mod. Its function is to read the diag_table.yaml to fill in +!! the diag_yaml_object + +!> @file +!> @brief File for @ref diag_yaml_mod + +!> @addtogroup fms_diag_yaml_mod +!> @{ module fms_diag_yaml_mod +#ifdef use_yaml +use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type, diag_yaml_files_obj_init, & + NUM_SUB_REGION_ARRAY +use yaml_parser_mod +use mpp_mod -use diag_data_mod, only: diag_files_type, diag_fields_type +implicit none -integer, parameter :: basedate_size = 7 +private -!> Object that holds the information of the diag_yaml -type diag_yaml_object - character(len=:), allocatable, private :: diag_title !< Experiment name - integer, private, dimension (basedate_size) :: diag_basedate !< basedate array - type(diag_files_type), allocatable, private, dimension (:) :: diag_files!< History file info - type(diag_fields_type), allocatable, private, dimension (:,:) :: diag_fields !< Diag fields info - contains - procedure :: title => get_title !< Returns the title - procedure :: basedate => get_basedate !< Returns the basedate array -end type diag_yaml_object -type (diag_yaml_object) :: diag_yaml +public :: diag_yaml_object_init, diag_yaml_object_end +!> @} -public :: get_title, get_basedate +integer, parameter :: basedate_size = 6 +!> @brief Object that holds the information of the diag_yaml +!> @ingroup fms_diag_yaml_mod +type diagYamlObject_type + character(len=:), allocatable, private :: diag_title !< Experiment name + integer, private, dimension (basedate_size) :: diag_basedate !< basedate array + type(diagYamlFiles_type), allocatable, private, dimension (:) :: diag_files!< History file info + type(diagYamlFilesVar_type), allocatable, private, dimension (:) :: diag_fields !< Diag fields info + contains + procedure :: get_title !< Returns the title + procedure :: get_basedate !< Returns the basedate array +end type diagYamlObject_type + +type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml + +!> @addtogroup fms_diag_yaml_mod +!> @{ contains -!> \brief Returns the basedate as an integer array +!> @brief get the basedate of a diag_yaml type +!! @return the basedate as an integer array pure function get_basedate (diag_yaml) result (diag_basedate) -class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml -integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return -diag_basedate = diag_yaml%diag_basedate + class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml + integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return + + diag_basedate = diag_yaml%diag_basedate end function get_basedate -!> \brief Returns the title of the diag table as an allocated string + +!> @brief get the title of a diag_yaml type +!! @return the title of the diag table as an allocated string pure function get_title (diag_yaml) result (diag_title) -class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml -character(len=:),allocatable :: diag_title !< Basedate array result to return - diag_title = diag_yaml%diag_title + class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml + character(len=:),allocatable :: diag_title !< Basedate array result to return + + diag_title = diag_yaml%diag_title end function get_title -!> \brief Compares two field type variables -pure logical function is_field_type_null (in1) -type(diag_fields_type), intent(in) :: in1 -is_field_type_null = .true. -end function is_field_type_null - -!!TODO -!> \brief looks for a diag_field based on it's name. -!! Returns null if field is not found. -!type(diag_fields_type)function get_diag_table_field (field_name) result (field) -! character(len=*), intent(IN) :: field_name -! integer :: i -! do i = 1,size(diag_fields) -! if (trim(field_name) == trim(fms_c2f_string(diag_fields(i)%fname))) then -! field = diag_fields(i) -!write (6,*) field_name//" Found" -! -! return -! endif -! enddo -! field = null_field_type -! -!end function get_diag_table_field +!> @brief Uses the yaml_parser_mod to read in the diag_table and fill in the +!! diag_yaml object +subroutine diag_yaml_object_init + integer :: diag_yaml_id !< Id for the diag_table yaml + integer :: nfiles !< Number of files in the diag_table yaml + integer, allocatable :: diag_file_ids(:) !< Ids of the files in the diag_table yaml + integer :: i, j !< For do loops + integer :: total_nvars !< The total number of variables in the diag_table yaml + integer :: var_count !< The current number of variables added to the diag_yaml obj + integer :: nvars !< The number of variables in the current file + integer, allocatable :: var_ids(:) !< Ids of the variables in diag_table yaml + + 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) + call get_value_from_key(diag_yaml_id, 0, "base_date", diag_yaml%diag_basedate) + + nfiles = get_num_blocks(diag_yaml_id, "diag_files") + allocate(diag_yaml%diag_files(nfiles)) + allocate(diag_file_ids(nfiles)) + call get_block_ids(diag_yaml_id, "diag_files", diag_file_ids) + + total_nvars = get_total_num_vars(diag_yaml_id, diag_file_ids) + allocate(diag_yaml%diag_fields(total_nvars)) + + var_count = 0 + nfiles_loop: do i = 1, nfiles + call diag_yaml_files_obj_init(diag_yaml%diag_files(i)) + call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(i)) + + nvars = 0 + nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i)) + allocate(var_ids(nvars)) + call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i)) + nvars_loop: do j = 1, nvars + var_count = var_count + 1 + call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count)) + enddo nvars_loop + deallocate(var_ids) + enddo nfiles_loop + + deallocate(diag_file_ids) +end subroutine + +!> @brief Destroys the diag_yaml object +subroutine diag_yaml_object_end() + integer :: i !< For do loops + + do i = 1, size(diag_yaml%diag_files, 1) + if(allocated(diag_yaml%diag_files(i)%file_global_meta)) deallocate(diag_yaml%diag_files(i)%file_global_meta) + if(allocated(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)) & + deallocate(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region) + if(allocated(diag_yaml%diag_files(i)%file_sub_region%index_sub_region)) & + deallocate(diag_yaml%diag_files(i)%file_sub_region%index_sub_region) + enddo + if(allocated(diag_yaml%diag_files)) deallocate(diag_yaml%diag_files) + + do i = 1, size(diag_yaml%diag_fields, 1) + if(allocated(diag_yaml%diag_fields(i)%var_attributes)) deallocate(diag_yaml%diag_fields(i)%var_attributes) + enddo + if(allocated(diag_yaml%diag_fields)) deallocate(diag_yaml%diag_fields) + +end subroutine diag_yaml_object_end + +!> @brief Fills in a diagYamlFiles_type with the contents of a file block in diag_table.yaml +subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) + integer, intent(in) :: diag_yaml_id !< Id of the diag_table.yaml + integer, intent(in) :: diag_file_id !< Id of the file block to read + type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to read the contents into + + integer :: nsubregion !< Flag indicating of there any regions (0 or 1) + integer :: sub_region_id(1) !< Id of the sub_region block + integer :: natt !< Number of global attributes in the current file + integer :: global_att_id(1) !< Id of the global attributes block + integer :: nkeys !< Number of key/value global attributes pair + integer :: j !< For do loops + + integer, allocatable :: key_ids(:) !< Id of the gloabl atttributes key/value pairs + + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", fileobj%file_frequnit) + call get_value_from_key(diag_yaml_id, diag_file_id, "freq", fileobj%file_freq) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "write_file", fileobj%string_file_write, is_optional=.true.) + if (fileobj%string_file_write .eq. "false") fileobj%file_write = .false. + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "realm", fileobj%file_realm, is_optional=.true.) + call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", fileobj%file_new_file_freq_units, & + is_optional=.true.) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.) + call get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", fileobj%file_duration, is_optional=.true.) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", fileobj%file_duration_units, & + is_optional=.true.) + + nsubregion = 0 + nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id) + if (nsubregion .eq. 1) then + call get_block_ids(diag_yaml_id, "sub_region", sub_region_id, parent_block_id=diag_file_id) + call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", fileobj%file_sub_region%grid_type) + if (trim(fileobj%file_sub_region%grid_type) .eq. "latlon") then + allocate(fileobj%file_sub_region%lat_lon_sub_region(8)) + call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%lat_lon_sub_region) + elseif (trim(fileobj%file_sub_region%grid_type) .eq. "index") then + allocate(fileobj%file_sub_region%index_sub_region(8)) + call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region) + call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.) + if (fileobj%file_sub_region%tile .eq. 0) call mpp_error(FATAL, "The tile number is required when defining a "//& + "subregion. Check your subregion entry for "//trim(fileobj%file_fname)) + endif + elseif (nsubregion .ne. 0) then + call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple region blocks") + endif + + natt = 0 + natt = get_num_blocks(diag_yaml_id, "global_meta", parent_block_id=diag_file_id) + if (natt .eq. 1) then + call get_block_ids(diag_yaml_id, "global_meta", global_att_id, parent_block_id=diag_file_id) + nkeys = get_nkeys(diag_yaml_id, global_att_id(1)) + allocate(key_ids(nkeys)) + call get_key_ids(diag_yaml_id, global_att_id(1), key_ids) + + allocate(fileobj%file_global_meta(nkeys, 2)) + do j = 1, nkeys + call get_key_name(diag_yaml_id, key_ids(j), fileobj%file_global_meta(j, 1)) + call get_key_value(diag_yaml_id, key_ids(j), fileobj%file_global_meta(j, 2)) + enddo + deallocate(key_ids) + elseif (natt .ne. 0) then + call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple global_meta blocks") + endif + +end subroutine + +!> @brief Fills in a diagYamlFilesVar_type with the contents of a variable block in +!! diag_table.yaml +subroutine fill_in_diag_fields(diag_file_id, var_id, field) + integer, intent(in) :: diag_file_id !< Id of the file block in the yaml file + integer, intent(in) :: var_id !< Id of the variable block in the yaml file + type(diagYamlFilesVar_type), intent(out) :: field !< diagYamlFilesVar_type obj to read the contents into + + + integer :: natt !< Number of attributes in variable + integer :: var_att_id(1) !< Id of the variable attribute block + integer :: nkeys !< Number of key/value pairs of attributes + integer :: j !< For do loops + + integer, allocatable :: key_ids(:) !< Id of each attribute key/value pair + + field%var_write = .true. + call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname) + call diag_get_value_from_key(diag_file_id, var_id, "reduction", field%var_reduction) + call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module) + call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind) + call diag_get_value_from_key(diag_file_id, var_id, "write_var", field%string_var_write, is_optional=.true.) + if (trim(field%string_var_write) .eq. "false") field%var_write = .false. + + call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname) + call diag_get_value_from_key(diag_file_id, var_id, "long_name", field%var_longname, is_optional=.true.) + !! VAR_UNITS !! + + natt = 0 + natt = get_num_blocks(diag_file_id, "attributes", parent_block_id=var_id) + if (natt .eq. 1) then + call get_block_ids(diag_file_id, "attributes", var_att_id, parent_block_id=var_id) + nkeys = get_nkeys(diag_file_id, var_att_id(1)) + allocate(key_ids(nkeys)) + call get_key_ids(diag_file_id, var_att_id(1), key_ids) + + allocate(field%var_attributes(nkeys, 2)) + do j = 1, nkeys + call get_key_name(diag_file_id, key_ids(j), field%var_attributes(j, 1)) + call get_key_value(diag_file_id, key_ids(j), field%var_attributes(j, 2)) + enddo + deallocate(key_ids) + elseif (natt .ne. 0) then + call mpp_error(FATAL, "diag_yaml_object_init: variable "//trim(field%var_varname)//" has multiple attribute blocks") + endif + +end subroutine + +!> @brief diag_manager wrapper to get_value_from_key to use for allocatable +!! string variables +subroutine diag_get_value_from_key(diag_file_id, par_id, key_name, value_name, is_optional) + integer, intent(in) :: diag_file_id!< Id of the file block in the yaml file + integer, intent(in) :: par_id !< Id of the parent block in the yaml file + character(len=*), intent(in) :: key_name !< Key to look for in the parent block + character(len=:), allocatable :: value_name !< Value of the key + logical, intent(in), optional :: is_optional !< Flag indicating if the key is optional + + character(len=255) :: buffer !< String buffer to read in to + + buffer = "" !< Needs to be initialized for optional keys that are not present + call get_value_from_key(diag_file_id, par_id, trim(key_name), buffer, is_optional= is_optional) + allocate(character(len=len_trim(buffer)) :: value_name) + value_name = trim(buffer) + +end subroutine diag_get_value_from_key + +!> @brief gets the lat/lon of the sub region to use in a diag_table yaml +subroutine get_sub_region(diag_yaml_id, sub_region_id, sub_region) + integer, intent(in) :: diag_yaml_id !< Id of the diag_table yaml file + integer, intent(in) :: sub_region_id !< Id of the region block to read from + class(*),intent(out) :: sub_region (NUM_SUB_REGION_ARRAY) !< Array storing the bounds of the sub region + + call get_value_from_key(diag_yaml_id, sub_region_id, "dim1_begin", sub_region(1), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim1_end", sub_region(2), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim2_begin", sub_region(3), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim2_end", sub_region(4), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim3_begin", sub_region(5), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim3_end", sub_region(6), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim4_begin", sub_region(7), is_optional=.true.) + call get_value_from_key(diag_yaml_id, sub_region_id, "dim4_end", sub_region(8), is_optional=.true.) + +end subroutine get_sub_region + +!> @brief gets the total number of variables in the diag_table yaml file +!! @return total number of variables +function get_total_num_vars(diag_yaml_id, diag_file_ids) & +result(total_nvars) + + integer, intent(in) :: diag_yaml_id !< Id for the diag_table yaml + integer, intent(in) :: diag_file_ids(:) !< Ids of the files in the diag_table yaml + integer :: total_nvars + integer :: i !< For do loop + total_nvars = 0 + do i = 1, size(diag_file_ids,1) + total_nvars = total_nvars + get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i)) + end do +end function +#endif end module fms_diag_yaml_mod +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90 index b26a4a3bdc..e406885084 100644 --- a/diag_manager/fms_diag_yaml_object.F90 +++ b/diag_manager/fms_diag_yaml_object.F90 @@ -18,10 +18,10 @@ !*********************************************************************** !> @defgroup fms_diag_yaml_object_mod fms_diag_yaml_object_mod !> @ingroup diag_manager -!! @brief The diag yaml objects are handled here, with variables the correspond to -!! entries in the diag yaml file. The actual parsing of the yaml is handled in +!! @brief The diag yaml objects are handled here, with variables the correspond to +!! entries in the diag yaml file. The actual parsing of the yaml is handled in !! @ref fms_diag_yaml_mod. -!! @author Tom Robinson +!! @author Tom Robinson, Uriel Ramirez !> @file !> @brief File for @ref fms_diag_yaml_object_mod @@ -33,64 +33,57 @@ module fms_diag_yaml_object_mod use fms_mod , only: fms_c2f_string use iso_c_binding implicit none -integer, parameter :: NUM_REGION_ARRAY = 8 - !> @brief The files type matching a C struct containing diag_yaml information - !> @ingroup fms_diag_files_mod -type, bind(c) :: diag_yaml_files_struct - character (kind=c_char) :: file_fname (20) !< file name - character (kind=c_char) :: file_frequnit (7) !< the frequency unit - integer (c_int) :: file_freq !< the frequency of data - character (kind=c_char) :: file_timeunit(7) !< The unit of time - character (kind=c_char) :: file_unlimdim(8) !< The name of the unlimited dimension - character (kind=c_char) :: file_write (5) !< false if the user doesn’t want the file to be - !! created (default is true). - character (kind=c_char) :: file_realm (3) !< The modeling realm that the variables come from - real (c_float) :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture - integer (c_int) :: file_new_file_freq !< Frequency for closing the existing file - character (kind=c_char) :: file_new_file_freq_units (3)!< Time units for creating a new file. - !! Required if “new_file_freq” used - integer (c_int) :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq” - integer (c_int) :: file_duration !< How long the file should receive data after start time - !! in “file_duration_units”.  This optional field can only - !! be used if the start_time field is present.  If this field - !! is absent, then the file duration will be equal to the - !! frequency for creating new files.  - !! NOTE: The file_duration_units field must also be present if - !! this field is present. - character (kind=c_char) :: file_duration_units (3)!< The file duration units -end type diag_yaml_files_struct +integer, parameter :: NUM_SUB_REGION_ARRAY = 8 +integer, parameter :: MAX_STR_LEN = 255 + +!> @brief type to hold the sub region information about a file +type subRegion_type + character (len=:), allocatable :: grid_type !< Flag indicating the type of region, + !! acceptable values are "latlon" and "index" + real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region + !! to use if grid_type is set to "latlon" + !! [dim1_begin, dim1_end, dim2_begin, dim2_end, + !! dim3_begin, dim3_end, dim4_begin, dim4_end] + integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to + !! to use if grid_type is set to "index" + !! [dim1_begin, dim1_end, dim2_begin, dim2_end, + !! dim3_begin, dim3_end, dim4_begin, dim4_end] + integer :: tile !< Tile number of the sub region, required if using the "index" grid type + +end type subRegion_type -type diag_yaml_files_type +type diagYamlFiles_type character (len=:), allocatable :: file_fname !< file name character (len=:), allocatable :: file_frequnit !< the frequency unit integer (c_int) :: file_freq !< the frequency of data character (len=:), allocatable :: file_timeunit !< The unit of time character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension logical :: file_write - character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be + character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be !! created (default is true). character (len=:), allocatable :: file_realm !< The modeling realm that the variables come from - real :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture + type(subRegion_type) :: file_sub_region !< type containing info about the subregion, if any integer :: file_new_file_freq !< Frequency for closing the existing file - character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file. + character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file. !! Required if “new_file_freq” used - integer :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq” - integer :: file_duration !< How long the file should receive data after start time - !! in “file_duration_units”.  This optional field can only + character (len=:), allocatable :: file_start_time !< Time to start the file for the first time. Requires + !! “new_file_freq” + integer :: file_duration !< How long the file should receive data after start time + !! in “file_duration_units”.  This optional field can only !! be used if the start_time field is present.  If this field !! is absent, then the file duration will be equal to the - !! frequency for creating new files.  + !! frequency for creating new files. !! NOTE: The file_duration_units field must also be present if !! this field is present. character (len=:), allocatable :: file_duration_units !< The file duration units - character (len=:), dimension(:), allocatable :: file_varlist !< An array of variable names + !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length + character (len=MAX_STR_LEN), dimension(:), allocatable :: file_varlist !< An array of variable names !! within a file - character (len=:), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1) - !! and values(dim=2) to be added as global + character (len=MAX_STR_LEN), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1) + !! and values(dim=2) to be added as global !! meta data to the file contains - procedure :: copy_struct => copy_file_struct_to_object procedure :: get_file_fname procedure :: get_file_frequnit procedure :: get_file_freq @@ -98,7 +91,7 @@ module fms_diag_yaml_object_mod procedure :: get_file_unlimdim procedure :: get_file_write procedure :: get_file_realm - procedure :: get_file_region + procedure :: get_file_sub_region procedure :: get_file_new_file_freq procedure :: get_file_new_file_freq_units procedure :: get_file_start_time @@ -107,24 +100,9 @@ module fms_diag_yaml_object_mod procedure :: get_file_varlist procedure :: get_file_global_meta -end type diag_yaml_files_type +end type diagYamlFiles_type -!> @brief The field type matching the C struct for diag_yaml information - !> @ingroup fms_diag_files_mod -type, bind(c) :: diag_yaml_files_var_struct - character (kind=c_char) :: var_fname (20) !< The field/diagnostic name - character (kind=c_char) :: var_varname(20) !< The name of the variable - character (kind=c_char) :: var_reduction(20) !< Reduction to be done on var - character (kind=c_char) :: var_module(20) !< The module that th variable is in - character (kind=c_char) :: var_skind(8) !< The type/kind of the variable - character (kind=c_char) :: var_write(5) !< false if the user doesn’t want the variable to be - !! written to the file (default: true). - character (kind=c_char) :: var_outname(20) !< Name of the variable as written to the file - character (kind=c_char) :: var_longname(100) !< Overwrites the long name of the variable - character (kind=c_char) :: var_units(10) !< Overwrites the units -end type diag_yaml_files_var_struct - -type diag_yaml_files_var_type +type diagYamlFilesVar_type character (len=:), allocatable :: var_fname !< The field/diagnostic name character (len=:), allocatable :: var_varname !< The name of the variable character (len=:), allocatable :: var_reduction !< Reduction to be done on var @@ -137,10 +115,10 @@ module fms_diag_yaml_object_mod character (len=:), allocatable :: var_outname !< Name of the variable as written to the file character (len=:), allocatable :: var_longname !< Overwrites the long name of the variable character (len=:), allocatable :: var_units !< Overwrites the units - character (len=:), dimension (:), allocatable :: var_attributes !< Attributes to overwrite or + !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length + character (len=MAX_STR_LEN), dimension (:, :), allocatable :: var_attributes !< Attributes to overwrite or !! add from diag_yaml contains - procedure :: copy_struct => copy_variable_struct_to_object procedure :: get_var_fname procedure :: get_var_varname procedure :: get_var_reduction @@ -152,130 +130,112 @@ module fms_diag_yaml_object_mod procedure :: get_var_write procedure :: get_var_attributes -end type diag_yaml_files_var_type +end type diagYamlFilesVar_type contains -!!!!!!!! YAML FILE ROUTINES !!!!!!!! -!< \brief Copies the information of the yaml struct to the fortran object holding the info -subroutine copy_file_struct_to_object(diag_files_obj, diag_files_struct) - class(diag_yaml_files_type) :: diag_files_obj !< Fortran-side object with diag_yaml info - type(diag_yaml_files_struct) :: diag_files_struct !< The C struct that has the diag_yaml - !! info - integer :: i !< For looping -!< Convert the C strings to Fortran strings - diag_files_obj%file_fname = fms_c2f_string (diag_files_struct%file_fname) - diag_files_obj%file_frequnit = fms_c2f_string (diag_files_struct%file_frequnit) - diag_files_obj%file_timeunit = fms_c2f_string (diag_files_struct%file_timeunit) - diag_files_obj%file_unlimdim = fms_c2f_string (diag_files_struct%file_unlimdim) - diag_files_obj%file_realm = fms_c2f_string (diag_files_struct%file_realm) - diag_files_obj%file_new_file_freq_units = fms_c2f_string (diag_files_struct%file_new_file_freq_units) - diag_files_obj%file_duration_units = fms_c2f_string (diag_files_struct%file_duration_units) -!< Set the file_write to be true or false - diag_files_obj%string_file_write = fms_c2f_string (diag_files_struct%file_write) - diag_files_obj%file_write = .true. - if (diag_files_obj%string_file_write(1:1)=="f" .or. & - diag_files_obj%string_file_write(1:1)=="F") & - diag_files_obj%file_write = .false. - deallocate (diag_files_obj%string_file_write) -!< Store the numbers - diag_files_obj%file_freq = diag_files_struct%file_freq -!$omp simd - do i = 1, NUM_REGION_ARRAY - diag_files_obj%file_region(i) = diag_files_struct%file_region(i) - enddo - diag_files_obj%file_new_file_freq = diag_files_struct%file_new_file_freq - diag_files_obj%file_start_time = diag_files_struct%file_start_time - diag_files_obj%file_duration = diag_files_struct%file_duration - -end subroutine copy_file_struct_to_object !!!!!!! YAML FILE INQUIRIES !!!!!!! -!> \brief Inquiry for diag_files_obj%file_fname +!> @brief Inquiry for diag_files_obj%file_fname +!! @return file_fname of a diag_yaml_file obj pure function get_file_fname (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_fname end function get_file_fname -!> \brief Inquiry for diag_files_obj%file_frequnit +!> @brief Inquiry for diag_files_obj%file_frequnit +!! @return file_frequnit of a diag_yaml_file_obj pure function get_file_frequnit (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_frequnit end function get_file_frequnit -!> \brief Inquiry for diag_files_obj%file_freq +!> @brief Inquiry for diag_files_obj%file_freq +!! @return file_freq of a diag_yaml_file_obj pure function get_file_freq(diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried integer :: res !< What is returned res = diag_files_obj%file_freq end function get_file_freq -!> \brief Inquiry for diag_files_obj%file_timeunit +!> @brief Inquiry for diag_files_obj%file_timeunit +!! @return file_timeunit of a diag_yaml_file_obj pure function get_file_timeunit (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_timeunit end function get_file_timeunit -!> \brief Inquiry for diag_files_obj%file_unlimdim +!> @brief Inquiry for diag_files_obj%file_unlimdim +!! @return file_unlimdim of a diag_yaml_file_obj pure function get_file_unlimdim(diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_unlimdim end function get_file_unlimdim -!> \brief Inquiry for diag_files_obj%file_write +!> @brief Inquiry for diag_files_obj%file_write +!! @return file_write of a diag_yaml_file_obj pure function get_file_write(diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried logical :: res !< What is returned res = diag_files_obj%file_write end function get_file_write -!> \brief Inquiry for diag_files_obj%file_realm +!> @brief Inquiry for diag_files_obj%file_realm +!! @return file_realm of a diag_yaml_file_obj pure function get_file_realm(diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (:), allocatable :: res !< What is returned res = diag_files_obj%file_realm end function get_file_realm -!> \brief Inquiry for diag_files_obj%file_region -pure function get_file_region (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - real :: res (NUM_REGION_ARRAY) !< What is returned - res = diag_files_obj%file_region -end function get_file_region -!> \brief Inquiry for diag_files_obj%file_new_file_freq +!> @brief Inquiry for diag_files_obj%file_subregion +!! @return file_sub_region of a diag_yaml_file_obj +pure function get_file_sub_region (diag_files_obj) result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + type(subRegion_type) :: res !< What is returned + res = diag_files_obj%file_sub_region +end function get_file_sub_region +!> @brief Inquiry for diag_files_obj%file_new_file_freq +!! @return file_new_file_freq of a diag_yaml_file_obj pure function get_file_new_file_freq(diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried integer :: res !< What is returned res = diag_files_obj%file_new_file_freq end function get_file_new_file_freq -!> \brief Inquiry for diag_files_obj%file_new_file_freq_units +!> @brief Inquiry for diag_files_obj%file_new_file_freq_units +!! @return file_new_file_freq_units of a diag_yaml_file_obj pure function get_file_new_file_freq_units (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (:), allocatable :: res !< What is returned res = diag_files_obj%file_new_file_freq_units end function get_file_new_file_freq_units -!> \brief Inquiry for diag_files_obj%file_start_time +!> @brief Inquiry for diag_files_obj%file_start_time +!! @return file_start_time of a diag_yaml_file_obj pure function get_file_start_time (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried - integer :: res !< What is returned + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned res = diag_files_obj%file_start_time end function get_file_start_time -!> \brief Inquiry for diag_files_obj%file_duration +!> @brief Inquiry for diag_files_obj%file_duration +!! @return file_duration of a diag_yaml_file_obj pure function get_file_duration (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried integer :: res !< What is returned res = diag_files_obj%file_duration end function get_file_duration -!> \brief Inquiry for diag_files_obj%file_duration_units +!> @brief Inquiry for diag_files_obj%file_duration_units +!! @return file_duration_units of a diag_yaml_file_obj pure function get_file_duration_units (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (:), allocatable :: res !< What is returned res = diag_files_obj%file_duration_units end function get_file_duration_units -!> \brief Inquiry for diag_files_obj%file_varlist +!> @brief Inquiry for diag_files_obj%file_varlist +!! @return file_varlist of a diag_yaml_file_obj pure function get_file_varlist (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (:), allocatable :: res(:) !< What is returned res = diag_files_obj%file_varlist end function get_file_varlist -!> \brief Inquiry for diag_files_obj%file_global_meta +!> @brief Inquiry for diag_files_obj%file_global_meta +!! @return file_global_meta of a diag_yaml_file_obj pure function get_file_global_meta (diag_files_obj) result (res) - class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried character (:), allocatable :: res(:,:) !< What is returned res = diag_files_obj%file_global_meta end function get_file_global_meta @@ -283,91 +243,93 @@ end function get_file_global_meta !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!! -!< \brief Copies the information of the yaml struct to the fortran object holding the var info -subroutine copy_variable_struct_to_object(diag_var_obj, diag_var_struct) - class(diag_yaml_files_var_type) :: diag_var_obj !< Fortran-side object with diag_yaml var info - type(diag_yaml_files_var_struct) :: diag_var_struct !< The C struct that has the diag_yaml - !! var info -!< Convert the C strings to Fortran strings - diag_var_obj%var_fname = fms_c2f_string (diag_var_struct%var_fname) - diag_var_obj%var_varname = fms_c2f_string (diag_var_struct%var_varname) - diag_var_obj%var_reduction = fms_c2f_string (diag_var_struct%var_reduction) - diag_var_obj%var_module = fms_c2f_string (diag_var_struct%var_module) - diag_var_obj%var_skind = fms_c2f_string (diag_var_struct%var_skind) - diag_var_obj%var_outname = fms_c2f_string (diag_var_struct%var_outname) - diag_var_obj%var_longname = fms_c2f_string (diag_var_struct%var_longname) - diag_var_obj%var_units = fms_c2f_string (diag_var_struct%var_units) -!< Set the file_write to be true or false - diag_var_obj%string_var_write= fms_c2f_string (diag_var_struct%var_write) - diag_var_obj%var_write= .true. - if (diag_var_obj%string_var_write(1:1)=="f" .or. & - diag_var_obj%string_var_write(1:1)=="F") & - diag_var_obj%var_write= .false. - deallocate (diag_var_obj%string_var_write) -end subroutine copy_variable_struct_to_object + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!! YAML VAR INQUIRIES !!!!!!! -!> \brief Inquiry for diag_yaml_files_var_obj%var_fname +!> @brief Inquiry for diag_yaml_files_var_obj%var_fname +!! @return var_fname of a diag_yaml_files_var_obj pure function get_var_fname (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_fname end function get_var_fname -!> \brief Inquiry for diag_yaml_files_var_obj%var_varname +!> @brief Inquiry for diag_yaml_files_var_obj%var_varname +!! @return var_varname of a diag_yaml_files_var_obj pure function get_var_varname (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_varname end function get_var_varname -!> \brief Inquiry for diag_yaml_files_var_obj%var_reduction +!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction +!! @return var_reduction of a diag_yaml_files_var_obj pure function get_var_reduction (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_reduction end function get_var_reduction -!> \brief Inquiry for diag_yaml_files_var_obj%var_module +!> @brief Inquiry for diag_yaml_files_var_obj%var_module +!! @return var_module of a diag_yaml_files_var_obj pure function get_var_module (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_module end function get_var_module -!> \brief Inquiry for diag_yaml_files_var_obj%var_skind +!> @brief Inquiry for diag_yaml_files_var_obj%var_skind +!! @return var_skind of a diag_yaml_files_var_obj pure function get_var_skind (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_skind end function get_var_skind -!> \brief Inquiry for diag_yaml_files_var_obj%var_outname +!> @brief Inquiry for diag_yaml_files_var_obj%var_outname +!! @return var_outname of a diag_yaml_files_var_obj pure function get_var_outname (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_outname end function get_var_outname -!> \brief Inquiry for diag_yaml_files_var_obj%var_longname +!> @brief Inquiry for diag_yaml_files_var_obj%var_longname +!! @return var_longname of a diag_yaml_files_var_obj pure function get_var_longname (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_longname end function get_var_longname -!> \brief Inquiry for diag_yaml_files_var_obj%var_units +!> @brief Inquiry for diag_yaml_files_var_obj%var_units +!! @return var_units of a diag_yaml_files_var_obj pure function get_var_units (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried character (len=:), allocatable :: res !< What is returned res = diag_var_obj%var_units end function get_var_units -!> \brief Inquiry for diag_yaml_files_var_obj%var_write +!> @brief Inquiry for diag_yaml_files_var_obj%var_write +!! @return var_write of a diag_yaml_files_var_obj pure function get_var_write (diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried logical :: res !< What is returned res = diag_var_obj%var_write end function get_var_write -!> \brief Inquiry for diag_yaml_files_var_obj%var_attributes +!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes +!! @return var_attributes of a diag_yaml_files_var_obj pure function get_var_attributes(diag_var_obj) result (res) - class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res (:) !< What is returned + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned res = diag_var_obj%var_attributes end function get_var_attributes +!> @brief Initializes the non string values of a diagYamlFiles_type to its +!! default values +subroutine diag_yaml_files_obj_init(obj) + type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize + + obj%file_freq = 0 + obj%file_write = .true. + obj%file_duration = 0 + obj%file_sub_region%lat_lon_sub_region = -999. + obj%file_sub_region%index_sub_region = -999 + obj%file_sub_region%tile = 0 +end subroutine diag_yaml_files_obj_init + end module fms_diag_yaml_object_mod !> @} ! close documentation grouping From 60c5e12400b9e701a504d2fbcadb138273491fb4 Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Tue, 4 Jan 2022 15:55:22 -0500 Subject: [PATCH 016/142] Adding the fms_diag_object container. (#867) * Initial commit of the fms_diag_object_container. Includes the underlying linked_list library, some changes to diag_manger to initialize the container and to use the container upon field registration, related Makefile.am changes. * Modified diag object iterator to fix casting compilation error on CI system. * Initial modificationss in response to a review by Tom Robinsom on 12/7/01. Mostly documentation, logging, and type name improvements. * Experimenting with documentation annotations. * Added test of fms_diag_object_container class. Further changes to follow convention and documentation. * Corrected script calling unit test. Added todo in fms_diag_yaml.F90. * Cleaned up test of container. * Addded a "TODO:" to fms_diag_yaml.F90, function is filed type null. * Modified new files and unit test for further compliance with coding standards * Renamed the linked list mod. Corrected CMakeList.txtx and a Makefile.am. * Renamed linked list mod. Changed a Makefile.am. * Fixed CMakeLists.txt. * Mods to CMakeLIst.txt. Includes adding parser dir files. * Fixing typo in CMakeLists.txt * Many comments and documentation chages based on Tom R's 2nd review. * Adds annotations @addtogroup and @{ to the diag object container mod and the linked list mod. * Added comments for the "this" variable. Nods to use "!<" for var comments. * Further doxygen related improvements. Some improvements on on calss access (private/public) lables. * Five chages of list node instance declarations from class to node to compile on Intel. * One change from type to class for an interator instance. Some comment updates. * Added test_diag_dlinked_list.F90. Modified memeber data/access in several in several types. Improved several comments. * Improved or added several comments. * Removed vs code related files. * Removing extraneous return statement in test_diag_dlinked_list.F90. * Improved test_diag_dlinked_list.F90, both code and comments. * Removed duplicate yaml_parser.F90 from CMakeLists.txt. * Incorporates changes based on Tom R's latest review. * Includes some doxygen related changes requested by Ryan M. --- CMakeLists.txt | 2 + diag_manager/Makefile.am | 17 +- diag_manager/diag_manager.F90 | 30 +- diag_manager/fms_diag_dlinked_list.F90 | 323 ++++++++++++++++++ diag_manager/fms_diag_object.F90 | 36 +- diag_manager/fms_diag_object_container.F90 | 261 ++++++++++++++ test_fms/diag_manager/Makefile.am | 6 +- .../diag_manager/test_diag_dlinked_list.F90 | 238 +++++++++++++ test_fms/diag_manager/test_diag_manager2.sh | 14 + .../test_diag_object_container.F90 | 237 +++++++++++++ 10 files changed, 1139 insertions(+), 25 deletions(-) create mode 100644 diag_manager/fms_diag_dlinked_list.F90 create mode 100644 diag_manager/fms_diag_object_container.F90 create mode 100644 test_fms/diag_manager/test_diag_dlinked_list.F90 create mode 100644 test_fms/diag_manager/test_diag_object_container.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index f995310139..ed85a57c87 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -116,6 +116,8 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_object.F90 diag_manager/fms_diag_yaml.F90 diag_manager/fms_diag_yaml_object.F90 + diag_manager/fms_diag_dlinked_list.F90 + diag_manager/fms_diag_object_container.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 19adddf346..ab3148ae63 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -31,8 +31,8 @@ noinst_LTLIBRARIES = libdiag_manager.la # Each convenience library depends on its source. libdiag_manager_la_SOURCES = \ - diag_axis.F90 \ diag_data.F90 \ + diag_axis.F90 \ diag_grid.F90 \ diag_manager.F90 \ diag_output.F90 \ @@ -40,7 +40,9 @@ libdiag_manager_la_SOURCES = \ diag_util.F90 \ fms_diag_yaml.F90 \ fms_diag_object.F90 \ - fms_diag_yaml_object.F90 + fms_diag_yaml_object.F90 \ + fms_diag_object_container.F90 \ + fms_diag_dlinked_list.F90 # Some mods are dependant on other mods in this dir. diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) @@ -49,12 +51,14 @@ 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_yaml_object_mod.$(FC_MODEXT) + fms_diag_yaml_object_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) \ fms_diag_yaml_object_mod.$(FC_MODEXT) +fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ - fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ + fms_diag_object_container_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ @@ -67,7 +71,10 @@ MODFILES = \ fms_diag_yaml_object_mod.$(FC_MODEXT) \ fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_object_mod.$(FC_MODEXT) \ + fms_diag_dlinked_list_mod.$(FC_MODEXT) \ + fms_diag_object_container_mod.$(FC_MODEXT) \ diag_manager_mod.$(FC_MODEXT) + nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 09d4c80e3f..4ad7b7a945 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -225,10 +225,14 @@ 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: fms_diag_object + use fms_diag_object_container_mod, ONLY: FmsDiagObjectContainer_t + #ifdef use_yaml use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end #endif USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder + USE constants_mod, ONLY: SECONDS_PER_DAY #ifdef use_netCDF @@ -264,6 +268,8 @@ MODULE diag_manager_mod type(time_type) :: Time_end + TYPE(FmsDiagObjectContainer_t), ALLOCATABLE :: the_diag_object_container + !> @brief Send data over to output fields. !! !> send_data is overloaded for fields having zero dimension @@ -428,6 +434,9 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t LOGICAL :: mask_variant1, verbose1 LOGICAL :: cm_found CHARACTER(len=128) :: msg + INTEGER :: status_ic !< used to check the status of insert into container. + CLASS(fms_diag_object), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered + TYPE(fms_diag_object), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object ! get stdout unit number stdout_unit = stdout() @@ -587,14 +596,24 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t END IF if (use_modern_diag) then - call diag_object_placeholder(1)%register & - (module_name, field_name, axes, init_time, & - long_name, units, missing_value, Range, mask_variant, standard_name, & - do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here) + !! Create a diag object, initialize it with the registered data, and insert + !! it ino the diag_obj_container singleton. + + allocate( diag_obj ) + call diag_obj%register (module_name, field_name, axes, init_time, & + long_name, units, missing_value, Range, mask_variant, standard_name, & + do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here) + + diag_obj_ptr => diag_obj + status_ic = the_diag_object_container%insert(diag_obj_ptr%get_id(), diag_obj_ptr) + if(status_ic .ne. 0) then + print *, "Insertion ERROR for id ", diag_obj_ptr%get_id() + endif endif END FUNCTION 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 register_static_field(module_name, field_name, axes, long_name, units,& @@ -3715,6 +3734,9 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & 'AXES LIST' END IF + !!Create the diag_object container; Its a singleton in the diag_data mod + the_diag_object_container = FmsDiagObjectContainer_t() + module_is_initialized = .TRUE. ! create axis_id for scalars here null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none') diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90 new file mode 100644 index 0000000000..99b4fb09ad --- /dev/null +++ b/diag_manager/fms_diag_dlinked_list.F90 @@ -0,0 +1,323 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @defgroup fms_diag_dlinked_list_mod fms_diag_dlinked_list_mod +!> @ingroup diag_manager +!> @brief fms_diag_dlinked_list_mod defines a generic doubly linked +!! list class and an iterator class for traversing the list. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_dlinked_list_mod defines a generic doubly linked +!! list class and an iterator class for traversing the list. It is +!! generic in the sense that the elements or objects it contains are +!! "class(*)" objects. If additional typecheking or psossibly a +!! slightly different user interface is desired, consider creating +!! a wrapper or another class with this one for a memeber element and +!! procedures that are trivially implemeted by using this class. +!! +!! This version is roughly a fortran translation of the C++ doubly linked list +!! class in the book ``Data Structures And Algorithm Analysis in C++", 3rd Edition, +!! by Mark Allen Weiss. + +!> @file +!> @brief File for @ref fms_diag_dlinked_list_mod +!> @addtogroup fms_diag_dlinked_list_mod +!> @{ +MODULE fms_diag_dlinked_list_mod + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE + implicit none + !!TODO: COnsider setting the access (public,private) to functions, etc. + !> The doubly-linked list node type. + type, public:: FmsDlListNode_t + private + class(*), pointer :: data => null() !< The data pointed to by the node. + type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node. + type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node. + end type FmsDlListNode_t + + !> Linked list iterator + type, public :: FmsDllIterator_t + private + type(FmsDlListNode_t), pointer :: current !< A pointer to the current node. + type(FmsDlListNode_t), pointer :: end !< A sentinel (non-data) node. + contains + procedure :: has_data => literator_has_data !< Function returns true is there is data in the iterator. + procedure :: next => literator_next !< Function moves the iterator to the next data element. + procedure :: get => literator_data !< Function return a pointer to the current data. + procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer. + end type FmsDllIterator_t + + !> The doubly-linked list type. Besides the member functions, see the + !! associated iterator class ( FmsDllIterator_t) for traversal, and note that + !! the default constructor is overriden with an interface of the same name. + type, public :: FmsDlList_t + private + type(FmsDlListNode_t), pointer :: head !< The sentinal (non-data) head node of the linked list. . + type(FmsDlListNode_t), pointer :: tail !< The sentinel (non-data) tail node of the linked list. + integer :: the_size !< The number of data elements in the linked list. + contains + procedure :: push_back => push_at_back + procedure :: pop_back => pop_at_back + procedure :: remove => remove_node + procedure :: get_literator => get_forward_literator + procedure :: size => get_size + procedure :: is_empty => is_size_zero + procedure :: clear => clear_all + final :: destructor + procedure :: insert => insert_data + + end type FmsDlList_t + + interface FmsDlListNode_t + module procedure :: node_constructor + end interface FmsDlListNode_t + + interface FmsDlList_t + module procedure :: linked_list_constructor + end interface FmsDlList_t + + interface FmsDllIterator_t + module procedure :: literator_constructor + end interface FmsDllIterator_t + +contains + + !> @brief Insert data d in a new node to be placed in front of the + !! target node t_nd. + !! @return Returns an iterator that starts with the newly inserted node. + function insert_data( this, t_nd, d ) result(liter) + class(FmsDlList_t), intent(in out) :: this ! d + !! Insert nd into list so that list section [prev node <--> target node ] looks like + !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or + !! from "new nd" need to be set. Therefore : + !! a) The new nd's prev needs to be whatever was the targets prev: + nd%prev => t_nd%prev + !! b) New node nd's next is obviously the target node: + nd%next => t_nd + !! c) the next of the prev node needs to point to the new node nd: + t_nd%prev%next => nd + !! d) target node's prev needs to point to the new node : + t_nd%prev => nd + this%the_size = this%the_size + 1 + liter = FmsDllIterator_t(nd, this%tail) + end function insert_data + + !> @brief Remove Node nd from the linked tree. + !! @return Return the iterator that begins with the next node after nd, and ends with + !! the list end node. Returns the list iterator if the node cannot be removed. + function remove_node( this, nd ) result( litr) + class(FmsDlList_t), intent(in out) :: this ! nd%next + nd%next%prev => nd%prev + deallocate(nd) + this%the_size = this%the_size - 1 + else + litr = this%get_literator() + endif + end function remove_node + + + !> @brief Remove the tail (last data node) of the list. + !! @return Returns an iterator to the remaining list. + function pop_at_back (this ) result( liter ) + class(FmsDlList_t), intent(in out) :: this ! this%tail%prev + liter = this%remove( nd ) + else + liter = this%get_literator() + endif + end function pop_at_back + + !> @brief Push (insert) data at the end of the list + !> @return Returns an iterator that starts at the tail of the list. + function push_at_back( this, d ) result(litr) + class(FmsDlList_t), intent(in out) :: this ! @brief Constructor for the node_type + !! @return Returns a nully allocated node. + function node_constructor () result (nd) + type(FmsDlListNode_t), allocatable :: nd !< The allocated node. + allocate(nd) + nd%data => null() + nd%prev => null() + nd%next => null() + end function node_constructor + + !> @brief Constructor for the linked list. + !! @return Returns a newly allocated linked list instance. + function linked_list_constructor () result (ll) + type(FmsDlList_t), allocatable :: ll !< The resultant linked list to be reutrned. + allocate(ll) + allocate(ll%head) + allocate(ll%tail) + !!print *, 'associated(ll%head) :' , associated(ll%head), & + !! ' associated(ll%head) :' , associated(ll%head) + ll%head%next => ll%tail + ll%tail%prev => ll%head + ll%the_size = 0 + end function linked_list_constructor + + !> @brief The list iterator constructor. + !! @return Returns a newly allocated list iterator. + function literator_constructor ( fnd, tnd ) result (litr) + type (FmsDlListNode_t), pointer :: fnd + !< The sentinal (non-data) "first node" of the iterator will be fnd + type (FmsDlListNode_t), pointer :: tnd + !< The sentinal (non-data) "last node" of the iterator will be tnd. + type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned. + allocate(litr) + litr%current => fnd + litr%end => tnd + end function literator_constructor + + !> @brief Getter for the size (the number of data elements) of the linked list. + !! @return Returns the size of the lined list. + function get_size (this) result (sz) + class(FmsDlList_t), intent(in out) :: this + ! @brief Determines if the size (number of data elements) of the list is zero. +!! @return Returns true if there are zero (0) data elements in the list; false otherwise. + function is_size_zero (this) result (r) + class(FmsDlList_t), intent(in out) :: this + ! @brief Create and return a new forward iterator for the list. + !> @return Returns a forward iterator for the linked list. + function get_forward_literator(this) result (litr) + class(FmsDlList_t), intent(in) :: this ! @brief Determine if the iterator has data. + !> @return Returns true iff the iterator has data. + function literator_has_data( this ) result( r ) + class(FmsDllIterator_t), intent(in) :: this + ! @brief Move the iterators current data node pointer to the next data node. + !! @return Returns a status of 0 if succesful, -1 otherwise. + function literator_next( this ) result( status ) + class(FmsDllIterator_t), intent(in out ) :: this + integer :: status !< The returned status. Failure possible is if iterator does not have data. + status = -1 + if(this%has_data() .eqv. .true.) then + this%current => this%current%next + status = 0 + endif + end function literator_next + + !> @brief Get the current data object pointed to by the iterator. + !! function does not allocate or assign the result if + !! the user mistakenly called it without data present. + !! @return Returns a pointer to the current data. + function literator_data( this ) result( rd ) + class(FmsDllIterator_t), intent(in) :: this ! null() + if (this%has_data() .eqv. .true.) then + rd => this%current%data + endif + end function literator_data + +!> @brief Get the current data object pointed to by the iterator. + !! function does not allocate or assign the result if + !! the user mistakenly called it without data present. + !! @return Returns a pointer to the current data. + function get_current_node_ptr( this ) result( pn ) + class(FmsDllIterator_t), intent(in) :: this ! this%current + end function get_current_node_ptr + + !> @brief Iterate over all the nodes, remove them and deallocate the client data + !! that the node was holding. + subroutine clear_all( this ) + class(FmsDlList_t), intent(inout) :: this ! this%head%next + iter = this%remove(nd) + pdata => iter%get() + if (associated(pdata) .eqv. .false.) then + call error_mesg ('doubly_linked_list:clear_all', & + 'linked list destructor containes unassociated data pointer', & + WARNING) + else + deallocate(pdata) + endif + end do + end subroutine clear_all + + !> @brief A destructor that deallocates every node and each nodes data element. + subroutine destructor(this) + type(FmsDlList_t) :: this ! @} +! close documentation grouping diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a07b50ba05..098cc76502 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -4,12 +4,13 @@ module fms_diag_object_mod !! \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 +!! 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 use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id + use diag_axis_mod, only: diag_axis_type use mpp_mod, only: fatal, note, warning, mpp_error use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type @@ -32,7 +33,7 @@ module fms_diag_object_mod type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table integer, allocatable, private :: diag_id !< unique id for varable - class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the + class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the !! file objects for this variable character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable logical, private :: static !< true is this is a static var @@ -41,12 +42,12 @@ module fms_diag_object_mod 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 :: 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 + character(len=:), allocatable, private :: realm !< String to set as the value !! to the modeling_realm attribute character(len=:), allocatable, private :: err_msg !< An error message character(len=:), allocatable, private :: interp_method !< The interp method to be used @@ -76,7 +77,7 @@ module fms_diag_object_mod 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 + procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. procedure :: setID => set_diag_id procedure :: is_registered => diag_ob_registered procedure :: set_type => set_vartype @@ -157,7 +158,7 @@ subroutine diag_obj_init(ob) end select end subroutine diag_obj_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!> \description Fills in and allocates (when necessary) the values in the diagnostic object +!> \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, axes, init_time, & @@ -195,11 +196,14 @@ subroutine fms_register_diag_field_obj & ! TO DO: ! dobj%diag_field = get_diag_table_field(trim(varname)) ! dobj%diag_field = diag_yaml%get_diag_field( + !! TODO : Discuss design. Is this a premature return that somehow should + !! indicate a warning or failure to the calling function and/or the log files? ! if (is_field_type_null(dobj%diag_field)) then ! dobj%diag_id = diag_not_found ! dobj%vartype = diag_null ! return ! endif + !> get the optional arguments if included and the diagnostic is in the diag table if (present(longname)) then allocate(character(len=len(longname)) :: dobj%longname) @@ -208,7 +212,7 @@ subroutine fms_register_diag_field_obj & if (present(standname)) then allocate(character(len=len(standname)) :: dobj%standname) dobj%standname = trim(standname) - endif + endif if (present(units)) then allocate(character(len=len(units)) :: dobj%units) dobj%units = trim(units) @@ -232,7 +236,7 @@ subroutine 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 + else dobj%missing_value = DIAG_NULL endif @@ -240,6 +244,8 @@ subroutine fms_register_diag_field_obj & ! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind !> Set the registered flag to true dobj%registered = .true. + ! save it in the diag object container. + end subroutine fms_register_diag_field_obj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief Sets the diag_id. This can only be done if a variable is unregistered @@ -272,7 +278,7 @@ subroutine set_vartype(objin , var) 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) + " r8, r4, i8, i4, or string.", warning) end select end subroutine set_vartype !> \brief Prints to the screen what type the diag variable is @@ -310,7 +316,7 @@ end subroutine what_is_vartype !!MZ Is this a TODO. Many problems: !> \brief Registers the object subroutine diag_ob_registered(objin , reg) - class (fms_diag_object) , intent(inout):: objin + class (fms_diag_object) , intent(inout):: objin logical , intent(in) :: reg !< If registering, this is true objin%registered = reg end subroutine diag_ob_registered @@ -330,11 +336,11 @@ subroutine copy_diag_obj(objin , objout) ! type (diag_fields_type) :: diag_field !< info from diag_table ! type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table - objout%diag_id = objin%diag_id + objout%diag_id = objin%diag_id ! class (fms_io_obj), allocatable, dimension(:) :: fms_fileobj !< fileobjs if (allocated(objin%metadata)) objout%metadata = objin%metadata - objout%static = objin%static + objout%static = objin%static if (allocated(objin%frequency)) objout%frequency = objin%frequency if (allocated(objin%varname)) objout%varname = objin%varname end select @@ -344,7 +350,7 @@ end subroutine copy_diag_obj integer function fms_diag_get_id (dobj) result(diag_id) class(fms_diag_object) , intent(inout) :: dobj ! character(*) , intent(in) :: varname -!> Check if the diag_object registration has been done +!> 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 diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90 new file mode 100644 index 0000000000..3d61abb135 --- /dev/null +++ b/diag_manager/fms_diag_object_container.F90 @@ -0,0 +1,261 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @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 fms_diag_object instances +!! +!> @author Miguel Zuniga +!! +!! fms_diag_object_container_mod defines a container for inserting, removing and +!! searching for fms_diag_object 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. +!! +!! Most of the functions in class FmsDiagObjectContainer_t are simple wrappers over +!! those of the underlying fms_doubly_linked_list_mod class. The find/search +!! are a little more than that, and what FmsDiagObjectContainer_t provides over the +!! underlying liked list is the search function, type checking, convenience, and a +!! fixed user interface defined for the intended use. +!! +!> @file +!> @brief File for @ref fms_diag_object_container_mod +!> @addtogroup fms_diag_object_container_mod +!> @{ +MODULE fms_diag_object_container_mod + use fms_diag_object_mod, only: fms_diag_object + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE + + !! Since this version is based on the FDS linked list: + use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t, FmsDlListNode_t + + implicit none + + !> @brief A container of fms_diag_object instances providing insert, remove , + !! find/search, and size public member functions. Iterator is provided by + !! the associated iterator class (see dig_obj_iterator class). + !! + !! This version does not enforce uniqueness of ID keys (I.e. it is not a set). + !! + type, public:: FmsDiagObjectContainer_t + private + TYPE (FmsDlList_t), ALLOCATABLE :: the_linked_list !< This version based on the FDS linked_list. + contains + procedure :: insert => insert_diag_object + procedure :: remove => remove_diag_object + procedure :: find => find_diag_object + procedure :: size => get_num_objects + procedure :: iterator => get_iterator + final :: destructor + end type FmsDiagObjectContainer_t + + + !> @brief Iterator used to traverse the objects of the container. + type, public :: FmsDiagObjIterator_t + private + type(FmsDllIterator_t) :: liter !< This version based on the FDS linked_list (and its iterator). + contains + procedure :: has_data => literator_has_data + procedure :: next => literator_next + procedure :: get => literator_data + end type FmsDiagObjIterator_t + + interface FmsDiagObjectContainer_t + module procedure :: diag_object_container_constructor + end interface FmsDiagObjectContainer_t + + interface FmsDiagObjIterator_t + module procedure :: diag_obj_iterator_constructor + end interface FmsDiagObjIterator_t + + +contains + + !> @brief Returns an empty iterator if a diag object with this ID was not found. + !! If the diag object was found, return an iterator with the current object being + !! the found object, ad the last/anchor being the last/anchor of the container. + !! Note that this routine can accept an optional iterator as input, which + !! is useful for chaining searches, which may be needed if there are key duplicates. + !! @return In iterator that starts from the inserted object. + function find_diag_object (this, id , iiter) result (riter) + class (FmsDiagObjectContainer_t), intent (in out) :: this + ! riter%get() + if(id == ptdo%get_id() ) then + EXIT + end if + status = riter%next() + end do + end function find_diag_object + + !> @brief insert diagnostic object obj with given id. + !! Objects are inserted at the back / end of the list + !! This version of the container also enforces that the + !! objects ID is equal the input id. + !! @return A status of -1 if there was an error, and 0 otherwise. + 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(fms_diag_object) , intent (in out) :: obj !< The object to insert + integer :: status !< The returned status. 0 for success. + class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator. + + status = -1 + if ( id .ne. obj%get_id() ) then + !!TODO: log error + endif + tliter = this%the_linked_list%push_back( obj ) + if(tliter%has_data() .eqv. .true. ) then + status = 0 + endif + end function + + !> @brief Remove and return the first object in the container with the corresponding id . + !! Note that if the client code does not already have a reference to the object being + !! removed, then the client may want to to use procedure find before using procedure remove. + !! If procedure find is used, consider calling remove with the iterator returned from find. + !! @return In iterator starting from the node that was following the removed node. + function remove_diag_object (this, id, iiter ) result (riter) + class (FmsDiagObjectContainer_t), intent (in out) :: this + ! riter%liter%get_current_node_pointer() + temp_liter = this%the_linked_list%remove( pn ) + riter = FmsDiagObjIterator_t(temp_liter) + end function + + !> @brief Getter for the number of objects help in the container. + !! @return Return the number of objects.. + function get_num_objects (this ) result (sz) + class (FmsDiagObjectContainer_t), intent (in out) :: this + !< The instance of the class that this function is bound to. + integer :: sz !< The returned result - the number of objects in container. + sz = this%the_linked_list%size() + end function + + + !> @brief Return an iterator for the objects in the container. + !! @return An iterator for the objects in the container. + function get_iterator (this) result (oliter) + class (FmsDiagObjectContainer_t), intent (in) :: this + ! @brief A consructor for a container's iterator. + !! @return An for a container's iterator. + function diag_obj_iterator_constructor( iliter ) result (diag_itr) + class (FmsDllIterator_t), allocatable :: iliter + !< An iterator. Normally the one that the container is based on. + class (FmsDiagObjIterator_t), allocatable :: diag_itr !< The returned diag object iterator. + allocate(diag_itr) + diag_itr%liter = iliter; + end function diag_obj_iterator_constructor + + !> @brief The default consructor for the container. + !! @return Returns a container. + function diag_object_container_constructor () result (doc) + type(FmsDiagObjectContainer_t), allocatable :: doc !< The resultant container. + allocate(doc) + doc%the_linked_list = FmsDlList_t() + !! print * , "In DOC constructor" + end function diag_object_container_constructor + + !> @brief Determines if there is more data that can be accessed via the iterator. + !> @return Returns true iff more data can be accessed via the iterator. + function literator_has_data( this ) result( r ) + class(FmsDiagObjIterator_t), intent(in) :: this + ! @brief Move the iterator to the next object. + !! @return Returns a status 0 if sucessful, or -1 if failed. + function literator_next( this ) result( status ) + class(FmsDiagObjIterator_t), intent(in out ) :: this + ! @brief Get the current data the iterator is pointing to. + !! Note the common use case is to call function has_data to decide if + !! this function should be called (again). + !! @return Returns a pointer to the current data. + function literator_data( this ) result( rdo ) + class(FmsDiagObjIterator_t), intent(in) :: this + ! null() + gp => this%liter%get() + select type(gp) + type is (fms_diag_object) !! "type is", not the (polymorphic) "class is" + rdo => gp + class default + CALL error_mesg ('diag_object_container:literator_data', & + 'Data to be accessed via iterator is not of expected type.',FATAL) + end select + end function literator_data + + !> @brief The destructor for the container. + subroutine destructor(this) + type(FmsDiagObjectContainer_t) :: this + ! @} +! close documentation grouping + diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index cf5d063e7b..05fd840297 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -28,11 +28,14 @@ AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_diag_manager test_diag_manager_time +check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \ + test_diag_dlinked_list # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 test_diag_manager_time_SOURCES = test_diag_manager_time.F90 +test_diag_object_container_SOURCES = test_diag_object_container.F90 +test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90 # Run the test. TESTS = test_diag_manager2.sh @@ -40,4 +43,5 @@ TESTS = test_diag_manager2.sh # Copy over other needed files to the srcdir EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh +# Clean up CLEANFILES = input.nml *.nc *.out diag_table diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90 new file mode 100644 index 0000000000..69fcdd3e90 --- /dev/null +++ b/test_fms/diag_manager/test_diag_dlinked_list.F90 @@ -0,0 +1,238 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!! fms_diag_dlinked_list_mod defines a generic doubly linked +!! list class and an associated iterator class for traversing the list. It +!! is generic in the sense that the elements or objects it contains are +!! "class(*)" objects. Note the public interface functions and the lack +!! of a search (or find) function as per the definition of a linked list. +!! If a search function, additional type cheeking, or possibly a +!! slightly different user interface is desired, then consider creating +!! another iterator and another wrapper, or another class with this one for +!! a member element and procedures that are trivially implemented by using +!! this class. (See, for example, class FmsDiagObjectContainer_t and its +!! associated iterator. +!! +!! This version is roughly a Fortran translation of the C++ doubly linked list +!! class in the book ``Data Structures And Algorithm Analysis in C++", +!! 3rd Edition, by Mark Allen Weiss. +program test_diag_dlinked_list + use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING + use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated + use mpp_io_mod, only: mpp_io_init + + use fms_diag_object_mod, only : fms_diag_object + use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t + + implicit none + + !> @brief This class is the type for the data to insert in the linked list. + type TestDummy_t + integer :: id = 0 + character(len=20) :: name + end type TestDummy_t + + !! + type (FmsDlList_t), allocatable :: list !< Instance of the linked list + class(FmsDllIterator_t), allocatable :: iter !< An iterator for the list + type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object + class(*), pointer :: p_obj !< A pointer to a class(*) object + integer, parameter :: num_objs = 40 !< Total number of objects tested + integer :: full_id_sum !< Sum of all the possible object id values + integer :: sum !< Temp sum of vaalues of id sets + !! + integer :: ierr !< An error flag + logical :: test_passed !< Flag indicating if the test_passed + !! These fields below used to initialize diag object data. TBD + integer :: id + character(:), allocatable :: mname, mname_pre + !! + + + test_passed = .true. !! will be set to false if there are any issues. + + call mpp_init(mpp_init_test_requests_allocated) + call mpp_io_init() + call mpp_set_stack_size(145746) + + !! Ids will initially be from 1 to num_objs, so : + full_id_sum = (num_objs * (num_objs + 1)) / 2 + + !!Create the list + list = FmsDlList_t() + + if( list%size() /= 0) then + test_passed = .false. + call mpp_error(FATAL, "list incorrect size. Expected 0 at start") + endif + mname_pre = "ATM" + + !! Initialize num_objs objects and insert into list one at a time. + !! The loop iterator is same as id - created in order to facilitate + !! some tests. + do id = 1, num_objs + !!Allocate on heap another test dummy object : + allocate (p_td_obj) + !! And set some of its dummy data : + call combine_str_int(mname_pre, id, mname) + p_td_obj%id = id + p_td_obj%name = mname + !! And have the "Char(*) pointer also point to it: + p_obj => p_td_obj + + !! Test insertion the common way : + iter = list%push_back( p_obj) + if(iter%has_data() .eqv. .false. ) then + test_passed = .false. + call mpp_error(FATAL, "List push_back error.") + endif + + enddo + + if( list%size() /= num_objs) then + test_passed = .false. + call mpp_error(FATAL, "List has incorrect size after inserts.") + endif + + + !! Test iteration over the entire list : + sum = 0 + sum = sum_ids_in_list ( list ) + + if( sum /= full_id_sum) then + test_passed = .false. + call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected") + endif + + if( list%size() /= num_objs) then + test_passed = .false. + call mpp_error(FATAL, "The list size is not as expected post inserts.") + endif + + !! Test a removal from the back (id should be num_objs) + p_obj => find_back_of_list( list) + iter = list%pop_back() + !! Note the client is resposible for managing memory of anything he explicitly + !! removes from the list: + deallocate(p_obj) + sum = sum_ids_in_list ( list ) + if( sum /= full_id_sum - num_objs ) then + test_passed = .false. + call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected") + endif + + !! Repeat - test removal from the back of list (should be (num_objs -1)). + p_obj => find_back_of_list( list) + iter = list%pop_back() + !! Note the client is resposible for managing memory of anything he explicitly + !! removes from the list: + deallocate(p_obj) + sum = sum_ids_in_list ( list ) + if( sum /= (full_id_sum - num_objs - (num_objs -1) )) then + test_passed = .false. + call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected") + endif + + call list%clear() + if( list%size() /= 0) then + test_passed = .false. + call mpp_error(FATAL, "List is incorrect size after clearing.") + endif + + write (6,*) "Finishing diag_dlinked_list tests." + + !! the list has a finalize/destructor which will deallocate data that is still it list. + !! equivalent to calling list%clear() as above. + deallocate(list) + + call MPI_finalize(ierr) + +CONTAINS + + + + !> @brief Cast the "class(*) input data to the expected type. + function get_typed_data( data_in ) result( rdo ) + class(*), intent(in), pointer :: data_in !< An input pointer to the class(*) object. + class(TestDummy_t), pointer :: rdo !< The resultant pointer to the expected underlying object type. + rdo => null() + + select type(data_in) + type is (TestDummy_t) !! "type is", not the (polymorphic) "class is" + rdo => data_in + class default + call mpp_error(FATAL, "Data to access is not of expected type.",FATAL) + end select + end function get_typed_data + + !> Calcualte the sum of the ids. + !! Exercises iteration over the list. + function sum_ids_in_list (list) result (rsum) + type (FmsDlList_t), allocatable :: list !< The linked list instance + integer :: rsum !< The resultant sum of ids + class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list + type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object + class(*), pointer :: p_obj !< A pointer to a class(*) object + integer :: ic_status !< A list insertion status. + !! + rsum = 0 + iter = list%get_literator() + do while( iter%has_data() .eqv. .true.) + p_obj => iter%get() + p_td_obj => get_typed_data (p_obj ) + id = p_td_obj%id + rsum = rsum + id + ic_status = iter%next() + end do + end function sum_ids_in_list + + !> Calcualate the sum of the ids. This also is a kind of search function, + !! so if the provided wrapper is not used, you have to write your own. + !! @return a pointer the object at the end of the list, or null if none + function find_back_of_list (list) result (p_rdo) + type (FmsDlList_t), allocatable :: list !< The linked list instance + class(TestDummy_t), pointer :: p_rdo !< The resultant back of list, + class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list + class(*), pointer :: p_obj !< A pointer to a class(*) object + integer :: ic_status !< A list insertion status. + !! + p_rdo => null() + iter = list%get_literator() + do while( iter%has_data() .eqv. .true.) + p_obj => iter%get() + p_rdo => get_typed_data (p_obj ) + ic_status = iter%next() + end do + end function find_back_of_list + + subroutine combine_str_int (str, num, rs) + character(:), allocatable, intent (in):: str + integer , intent (in) :: num + character(:), allocatable, intent (out) :: rs + character(len_trim(str) + 8) :: tmp + + write (tmp, "(A4,I4)") str,num + tmp = trim(tmp) + rs = tmp + end subroutine combine_str_int + + +end program test_diag_dlinked_list + + diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index a8f2bd2ede..bb04a606fc 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -64,6 +64,7 @@ setup_test() } + rm -f input.nml diag_table setup_test 1 "Test 1: Data array is too large in x and y direction" setup_test 2 "Test 2: Data array is too large in x direction" @@ -100,3 +101,16 @@ rm -f input.nml diag_table touch input.nml cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table run_test test_diag_manager_time 1 + +echo "Test container" +rm -f input.nml diag_table +touch input.nml +cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table +run_test test_diag_object_container 1 + + +echo "Test linked list " +rm -f input.nml diag_table +touch input.nml +cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table +run_test test_diag_dlinked_list 1 diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90 new file mode 100644 index 0000000000..1d02023ce8 --- /dev/null +++ b/test_fms/diag_manager/test_diag_object_container.F90 @@ -0,0 +1,237 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @brief This programs tests public member functions of the +!! FmsDiagObjectContainer_t and FmsDiagObjIterator_t. As these two classes +!! are largely wrappers to their underlying classes, it is also +!! testing the underlying container and iterator classes. The container +!! functions being tested are insert, remove, and size. The use of the iterators +!! is also being tested. +program test_diag_obj_container + use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING + use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated + use mpp_io_mod, only: mpp_io_init + + use fms_diag_object_mod, only : fms_diag_object + use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t + USE time_manager_mod, ONLY: time_type + + implicit none + !! + type (FmsDiagObjectContainer_t), allocatable :: container !< Instance of the container + class(FmsDiagObjIterator_t), allocatable :: iter !< An iterator for the container + type (fms_diag_object), allocatable , target :: obj_vec(:) !< A vector of objects + type (fms_diag_object), pointer:: pobj !< A pointer to an object + integer, parameter :: num_objs = 10 !< Total number of objects tested + integer :: full_id_sum !< Sum of all the possible object id values + integer :: sum !< Temp sum of vaalues of id sets + !! + integer :: ic_status !< A status flag returned from container functions + integer :: ierr !< An error flag + !! + logical :: test_passed !< Flag indicating if the test_passed + !! These fields below used to initialize diag object data. TBD + integer :: id + integer, dimension(2) :: axes + TYPE(time_type) :: init_time + !!type (diag_fields_type) :: diag_field + character(:), allocatable :: mname, vname, mname_pre, vname_pre + !! + + + test_passed = .true. !! will be set to false if there are any issues. + + call mpp_init(mpp_init_test_requests_allocated) + call mpp_io_init() + call mpp_set_stack_size(145746) + + !! Ids will initially be from 1 to num_objs, so : + full_id_sum = (num_objs * (num_objs + 1)) / 2 + + !!Create the container + container = FmsDiagObjectContainer_t() + !!In diag_manager, one module level container may be used instead of a local one like above. + + + !! Allocate some test objects. + !! NOTE: normally objects will be allocated one at a time with a stament like: + !! allocate(pobj, source = fms_diag_object(argument list )) + !! or via constructor like : + !! pobj => fms_diag_object(argument list ) + !! Once the object ID is set, it should be inserted into the container and then the + !! container will be considered the manager of that object and its memory (unless the object is removed). + !! Since type fms_diag_obj doesn't have a proper constructor yet, well be lazy by making array of objects + !! ( normal fixed size array the thing whose use we are replacing to begin with ) and consider these particular + !! objects to not be managed by the container. + allocate(obj_vec(num_objs)) + + !! Initialize each object and isnert into container one at a time. + + if( container%size() /= 0) then + test_passed = .false. + call mpp_error(FATAL, "Container incorrect size. Expected 0 at start") + endif + mname_pre = "ATM" + vname_pre = "xvar" + do id = 1, num_objs + call combine_str_int(mname_pre, id, mname) + call combine_str_int(vname_pre, id, vname ) + + pobj => obj_vec( id ) !!Note use of pointer to obj. + call pobj%setID(id) + + call pobj%register ("test_mod", vname, axes, init_time, "a_long_name") + + !!Insert object into the container. + ic_status = container%insert(pobj%get_id(), pobj) + if(ic_status .ne. 0)then + test_passed = .false. + call mpp_error(FATAL, "Container Insertion error.") + endif + enddo + + if( container%size() /= num_objs) then + test_passed = .false. + call mpp_error(FATAL, "Container has incorrect size after inserts.") + endif + + !!Search the container for a an object of specified key + iter = container%find(123) + if ( iter%has_data() .eqv. .true. ) then + test_passed = .false. + call mpp_error(FATAL, "Found in container unexpected object of id=123") + endif + + !!Again, search the container for a an object of specified key + iter = container%find(4) + if (iter%has_data() .neqv. .true. ) then + test_passed = .false. + call mpp_error(FATAL, "Did not find expected container object of id=4") + endif + + !! Iterate over all the objects in the container; + sum = 0 + iter = container%iterator() + do while( iter%has_data() .eqv. .true.) + pobj => iter%get() !!Note use of pointer and pointer assignment is preferred. + id = pobj%get_id( ) + !! vname = pobj%get_varname() !! print ... + sum = sum + id + ic_status = iter%next() + end do + + if( sum /= full_id_sum) then + test_passed = .false. + call mpp_error(FATAL, "Id sums via iteration over the container objects is not as expected") + endif + + if( container%size() /= num_objs) then + test_passed = .false. + call mpp_error(FATAL, "The container size is not as expected post inserts.") + endif + + + !! Test a removal **** + iter = container%iterator() + iter = container%remove( 4, iter ) + iter = container%find(4) + !! Verify the removal , part 1: + if ( iter%has_data() .eqv. .true.) then + test_passed = .false. + call mpp_error(FATAL, "Found object of id = 4 after removing it") + endif + !! Verify the removal , part 2 : + if (container%size() /= (num_objs - 1)) then + test_passed = .false. + call mpp_error(FATAL,"The_container%size() \= num_obj -1 after a removal ") + endif + + !! Verify the removal , part 3 : + !! Iterate over all the objects in the container AFTER the removal of id=4 object; + sum = 0 + iter = container%iterator() + do while( iter%has_data() .eqv. .true.) + pobj => iter%get() !!Note use of pointer and pointer assignment is preferred. + id = pobj%get_id( ) + !! vname = pobj%get_varname() !! print ... + sum = sum + id + ic_status = iter%next() + end do + if( sum /= full_id_sum - 4) then + test_passed = .false. + call mpp_error(FATAL, "Container incorrect id sums post removal of 4") + endif + !! End test a removal **** + + !! Test find and access object in the container + iter = container%find(7) + if (iter%has_data() .neqv. .true. ) then + test_passed = .false. + call mpp_error(FATAL, "Container did not find object of id=7") + endif + !! Check the find results more : + pobj => iter%get() + if(pobj%get_id() /= 7) then + test_passed = .false. + call mpp_error(FATAL," Id of returned object was not 7 ") + endif + !!TODO further access tests. + + + !! Manually clear out the container. + !! NOTE: In normal use this is NOT PERFORMED since with its finalize function, the container + !! deallocates all pointers and data it manages. However, the client needs to take care of + !! the diag objects the client has decided that the container should not manage. + !! In this wierd test case, all the diag objects were originally from a vector (a container itself!) + !! and not allocated on the heap one at a time, so this step is needed before program completion. + do id = 1, num_objs + iter = container%find(id) + if ( iter%has_data() .eqv. .true.) then + iter = container%remove( id, iter ) + endif + end do + + if( container%size() /= 0) then + test_passed = .false. + call mpp_error(FATAL, "Container is incorrect size after clearing.") + endif + + write (6,*) "Finishing diag_obj_container tests." + + !! the container has a finalize/destructor which will +deallocate(container) + +call MPI_finalize(ierr) + +CONTAINS + +subroutine combine_str_int (str, num, rs) + character(:), allocatable, intent (in):: str + integer , intent (in) :: num + character(:), allocatable, intent (out) :: rs + character(len_trim(str) + 8) :: tmp + + write (tmp, "(A4,I4)") str,num + tmp = trim(tmp) + rs = tmp +end subroutine combine_str_int + +end program test_diag_obj_container + + From 164e870e5816d5b6a0701568f2900cdac3d352ed Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Mon, 10 Jan 2022 06:58:39 -0500 Subject: [PATCH 017/142] Skipping tests of container and linked list. (#882) * Initial commit of the fms_diag_object_container. Includes the underlying linked_list library, some changes to diag_manger to initialize the container and to use the container upon field registration, related Makefile.am changes. * Modified diag object iterator to fix casting compilation error on CI system. * Initial modificationss in response to a review by Tom Robinsom on 12/7/01. Mostly documentation, logging, and type name improvements. * Experimenting with documentation annotations. * Added test of fms_diag_object_container class. Further changes to follow convention and documentation. * Corrected script calling unit test. Added todo in fms_diag_yaml.F90. * Cleaned up test of container. * Addded a "TODO:" to fms_diag_yaml.F90, function is filed type null. * Modified new files and unit test for further compliance with coding standards * Renamed the linked list mod. Corrected CMakeList.txtx and a Makefile.am. * Renamed linked list mod. Changed a Makefile.am. * Fixed CMakeLists.txt. * Mods to CMakeLIst.txt. Includes adding parser dir files. * Fixing typo in CMakeLists.txt * Many comments and documentation chages based on Tom R's 2nd review. * Adds annotations @addtogroup and @{ to the diag object container mod and the linked list mod. * Added comments for the "this" variable. Nods to use "!<" for var comments. * Further doxygen related improvements. Some improvements on on calss access (private/public) lables. * Five chages of list node instance declarations from class to node to compile on Intel. * One change from type to class for an interator instance. Some comment updates. * Added test_diag_dlinked_list.F90. Modified memeber data/access in several in several types. Improved several comments. * Improved or added several comments. * Removed vs code related files. * Removing extraneous return statement in test_diag_dlinked_list.F90. * Improved test_diag_dlinked_list.F90, both code and comments. * Removed duplicate yaml_parser.F90 from CMakeLists.txt. * Incorporates changes based on Tom R's latest review. * Includes some doxygen related changes requested by Ryan M. * Skipping linked list and the container tests by adding skip arg to calls in test_diaf_manager2.sh --- test_fms/diag_manager/test_diag_manager2.sh | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index bb04a606fc..d424ec55d0 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -106,11 +106,10 @@ echo "Test container" rm -f input.nml diag_table touch input.nml cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table -run_test test_diag_object_container 1 - +run_test test_diag_object_container 1 skip echo "Test linked list " rm -f input.nml diag_table touch input.nml cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table -run_test test_diag_dlinked_list 1 +run_test test_diag_dlinked_list 1 skip From ad7a14f77e05e4fc0649b801bff625756d67bd19 Mon Sep 17 00:00:00 2001 From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com> Date: Mon, 10 Jan 2022 09:53:41 -0500 Subject: [PATCH 018/142] Changes fms_diag_object to fmsDiagObject_type (#879) * Changes fms_diag_object to fmsDiagObject_type * Removes the multi-dimensional type extentions that will no be used --- diag_manager/diag_manager.F90 | 7 +- diag_manager/fms_diag_object.F90 | 85 +++++++------------ diag_manager/fms_diag_object_container.F90 | 16 ++-- .../diag_manager/test_diag_dlinked_list.F90 | 2 +- .../test_diag_object_container.F90 | 6 +- 5 files changed, 46 insertions(+), 70 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 4ad7b7a945..eb6ae66b0a 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -225,13 +225,12 @@ 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: fms_diag_object + USE fms_diag_object_mod, ONLY: fmsDiagObject_type use fms_diag_object_container_mod, ONLY: FmsDiagObjectContainer_t #ifdef use_yaml use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end #endif - USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder USE constants_mod, ONLY: SECONDS_PER_DAY @@ -435,8 +434,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t LOGICAL :: cm_found CHARACTER(len=128) :: msg INTEGER :: status_ic !< used to check the status of insert into container. - CLASS(fms_diag_object), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered - TYPE(fms_diag_object), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object + CLASS(fmsDiagObject_type), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered + TYPE(fmsDiagObject_type), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object ! get stdout unit number stdout_unit = stdout() diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 098cc76502..9c3c8b7e09 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -29,7 +29,7 @@ module fms_diag_object_mod implicit none !> \brief Object that holds all variable information -type fms_diag_object +type fmsDiagObject_type type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table integer, allocatable, private :: diag_id !< unique id for varable @@ -70,6 +70,15 @@ module fms_diag_object_mod real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object +!> \brief Extends the variable object to work with multiple types of data + class(*), allocatable :: vardata0 + class(*), allocatable, dimension(:) :: vardata1 + class(*), allocatable, dimension(:,:) :: vardata2 + class(*), allocatable, dimension(:,:,:) :: vardata3 + class(*), allocatable, dimension(:,:,:,:) :: vardata4 + class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 + + contains ! procedure :: send_data => fms_send_data !!TODO @@ -88,44 +97,18 @@ module fms_diag_object_mod procedure :: get_vartype => diag_obj_get_vartype procedure :: get_varname => diag_obj_get_varname -end type fms_diag_object -!> \brief Extends the variable object to work with multiple types of data -type, extends(fms_diag_object) :: fms_diag_object_scalar - class(*), allocatable :: vardata -end type fms_diag_object_scalar -type, extends(fms_diag_object) :: fms_diag_object_1d - class(*), allocatable, dimension(:) :: vardata -end type fms_diag_object_1d -type, extends(fms_diag_object) :: fms_diag_object_2d - class(*), allocatable, dimension(:,:) :: vardata -end type fms_diag_object_2d -type, extends(fms_diag_object) :: fms_diag_object_3d - class(*), allocatable, dimension(:,:,:) :: vardata -end type fms_diag_object_3d -type, extends(fms_diag_object) :: fms_diag_object_4d - class(*), allocatable, dimension(:,:,:,:) :: vardata -end type fms_diag_object_4d -type, extends(fms_diag_object) :: fms_diag_object_5d - class(*), allocatable, dimension(:,:,:,:,:) :: vardata -end type fms_diag_object_5d +end type fmsDiagObject_type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -type(fms_diag_object) :: null_ob -type(fms_diag_object_scalar) :: null_sc -type(fms_diag_object_1d) :: null_1d -type(fms_diag_object_2d) :: null_2d -type(fms_diag_object_3d) :: null_3d -type(fms_diag_object_4d) :: null_4d -type(fms_diag_object_5d) :: null_5d +type(fmsDiagObject_type) :: null_ob integer,private :: MAX_LEN_VARNAME integer,private :: MAX_LEN_META -type(fms_diag_object_3d) :: diag_object_placeholder (10) +!type(fmsDiagObject_type) :: diag_object_placeholder (10) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d -public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d +public :: fmsDiagObject_type +public :: null_ob public :: copy_diag_obj, fms_diag_get_id -public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d public :: fms_diag_object_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -140,19 +123,13 @@ subroutine fms_diag_object_init (mlv,mlm) MAX_LEN_META = mlm !> Initialize the null_d variables null_ob%diag_id = DIAG_NULL - null_sc%diag_id = DIAG_NULL - null_1d%diag_id = DIAG_NULL - null_2d%diag_id = DIAG_NULL - null_3d%diag_id = DIAG_NULL - null_4d%diag_id = DIAG_NULL - null_5d%diag_id = DIAG_NULL end subroutine fms_diag_object_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \Description Sets the diag_id to the not registered value. subroutine diag_obj_init(ob) - class (fms_diag_object) , intent(inout) :: ob + class (fmsDiagObject_type) , intent(inout) :: ob select type (ob) - class is (fms_diag_object) + class is (fmsDiagObject_type) ob%diag_id = diag_not_registered !null_ob%diag_id ob%registered = .false. end select @@ -164,7 +141,7 @@ subroutine fms_register_diag_field_obj & (dobj, modname, varname, axes, init_time, & longname, units, missing_value, varRange, mask_variant, standname, & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata) - class(fms_diag_object) , intent(inout) :: dobj + class(fmsDiagObject_type) , intent(inout) :: dobj CHARACTER(len=*), INTENT(in) :: modname !< The module name CHARACTER(len=*), INTENT(in) :: varname !< The variable name INTEGER, INTENT(in) :: axes(:) !< The axes indicies @@ -250,7 +227,7 @@ 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 (fms_diag_object) , intent(inout):: objin + class (fmsDiagObject_type) , intent(inout):: objin integer :: id if (allocated(objin%registered)) then if (objin%registered) then @@ -262,7 +239,7 @@ subroutine set_diag_id(objin , id) end subroutine set_diag_id !> \brief Find the type of the variable and store it in the object subroutine set_vartype(objin , var) - class (fms_diag_object) , intent(inout):: objin + class (fmsDiagObject_type) , intent(inout):: objin class(*) :: var select type (var) type is (real(kind=8)) @@ -283,7 +260,7 @@ subroutine set_vartype(objin , var) end subroutine set_vartype !> \brief Prints to the screen what type the diag variable is subroutine what_is_vartype(objin) - class (fms_diag_object) , intent(inout):: 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 @@ -316,17 +293,17 @@ end subroutine what_is_vartype !!MZ Is this a TODO. Many problems: !> \brief Registers the object subroutine diag_ob_registered(objin , reg) - class (fms_diag_object) , intent(inout):: objin + 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 (fms_diag_object) , intent(in) :: objin - class (fms_diag_object) , intent(inout) , allocatable :: objout !< The destination of the copy + class (fmsDiagObject_type) , intent(in) :: objin + class (fmsDiagObject_type) , intent(inout) , allocatable :: objout !< The destination of the copy select type (objout) - class is (fms_diag_object) + class is (fmsDiagObject_type) if (allocated(objin%registered)) then objout%registered = objin%registered @@ -348,7 +325,7 @@ end subroutine copy_diag_obj !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> \brief Returns the ID integer for a variable integer function fms_diag_get_id (dobj) result(diag_id) - class(fms_diag_object) , intent(inout) :: dobj + class(fmsDiagObject_type) , intent(inout) :: dobj ! character(*) , intent(in) :: varname !> Check if the diag_object registration has been done if (allocated(dobj%registered)) then @@ -366,7 +343,7 @@ end function fms_diag_get_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(fms_diag_object), allocatable, intent(in) :: dobj + class(fmsDiagObject_type), allocatable, intent(in) :: dobj character(:), allocatable :: rslt character (len=:), allocatable :: registered, vartype, varname, diag_id if ( .not. allocated (dobj)) then @@ -408,25 +385,25 @@ end function fms_diag_obj_as_string_basic function diag_obj_is_registered (obj) result (rslt) - class(fms_diag_object), intent(in) :: obj + 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(fms_diag_object), intent(in) :: obj + class(fmsDiagObject_type), intent(in) :: obj logical :: rslt rslt = obj%static end function diag_obj_is_static function diag_obj_get_vartype (obj) result (rslt) - class(fms_diag_object), intent(in) :: obj + class(fmsDiagObject_type), intent(in) :: obj integer :: rslt rslt = obj%vartype end function diag_obj_get_vartype function diag_obj_get_varname(obj) result (rslt) - class(fms_diag_object), intent(in) :: obj + class(fmsDiagObject_type), intent(in) :: obj character(len=len(obj%varname)) :: rslt rslt = obj%varname end function diag_obj_get_varname diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90 index 3d61abb135..b3fdae819c 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 fms_diag_object instances +!! for inserting, removing and searching for fmsDiagObject_type instances !! !> @author Miguel Zuniga !! !! fms_diag_object_container_mod defines a container for inserting, removing and -!! searching for fms_diag_object instances. It also defined an iterator for +!! searching for fmsDiagObject_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: fms_diag_object + use fms_diag_object_mod, only: fmsDiagObject_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 fms_diag_object instances providing insert, remove , + !> @brief A container of fmsDiagObject_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(fms_diag_object), pointer:: ptdo !< A pointer to temporaty diagnostic object + class(fmsDiagObject_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(fms_diag_object) , intent (in out) :: obj !< The object to insert + class(fmsDiagObject_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. @@ -232,13 +232,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 (fms_diag_object) !! "type is", not the (polymorphic) "class is" + type is (fmsDiagObject_type) !! "type is", not the (polymorphic) "class is" rdo => gp class default CALL error_mesg ('diag_object_container:literator_data', & diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90 index 69fcdd3e90..4dff25a97a 100644 --- a/test_fms/diag_manager/test_diag_dlinked_list.F90 +++ b/test_fms/diag_manager/test_diag_dlinked_list.F90 @@ -37,7 +37,7 @@ program test_diag_dlinked_list use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated use mpp_io_mod, only: mpp_io_init - use fms_diag_object_mod, only : fms_diag_object + use fms_diag_object_mod, only : fmsDiagObject_type use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t implicit none diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90 index 1d02023ce8..9a5b8e3251 100644 --- a/test_fms/diag_manager/test_diag_object_container.F90 +++ b/test_fms/diag_manager/test_diag_object_container.F90 @@ -28,7 +28,7 @@ program test_diag_obj_container use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated use mpp_io_mod, only: mpp_io_init - use fms_diag_object_mod, only : fms_diag_object + use fms_diag_object_mod, only : fmsDiagObject_type use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t USE time_manager_mod, ONLY: time_type @@ -36,8 +36,8 @@ program test_diag_obj_container !! type (FmsDiagObjectContainer_t), allocatable :: container !< Instance of the container class(FmsDiagObjIterator_t), allocatable :: iter !< An iterator for the container - type (fms_diag_object), allocatable , target :: obj_vec(:) !< A vector of objects - type (fms_diag_object), pointer:: pobj !< A pointer to an object + type (fmsDiagObject_type), allocatable , target :: obj_vec(:) !< A vector of objects + type (fmsDiagObject_type), pointer:: pobj !< A pointer to an object integer, parameter :: num_objs = 10 !< Total number of objects tested integer :: full_id_sum !< Sum of all the possible object id values integer :: sum !< Temp sum of vaalues of id sets From 2c218d0aabd5340bde8f157d15ade6efd128e163 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Wed, 12 Jan 2022 11:04:58 -0500 Subject: [PATCH 019/142] Dm update: diag_yaml_object_init() tests (#883) * adds some tests + error checking when reading the diag_table.yaml * reverts some type definitions to private * refactors test so that the stuff in diag_yaml_object can remain private * attempt at debugging the check_crashes.sh script * renames diag_table_26 to diag_table_yaml_26, adds some missing trims, use DIAG_NULL instead of hardcoding * test(parser): Change real comparison value to double (#886) Co-authored-by: rem1776 Co-authored-by: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Co-authored-by: rem1776 --- diag_manager/fms_diag_yaml.F90 | 204 +++++++++++- diag_manager/fms_diag_yaml_object.F90 | 24 +- test_fms/diag_manager/Makefile.am | 16 +- test_fms/diag_manager/check_crashes.sh | 163 +++++++++ .../diagTables/diag_table_yaml_26 | 61 ++++ test_fms/diag_manager/test_diag_manager2.sh | 7 + test_fms/diag_manager/test_diag_yaml.F90 | 311 ++++++++++++++++++ 7 files changed, 774 insertions(+), 12 deletions(-) create mode 100755 test_fms/diag_manager/check_crashes.sh create mode 100644 test_fms/diag_manager/diagTables/diag_table_yaml_26 create mode 100644 test_fms/diag_manager/test_diag_yaml.F90 diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 9a423697e0..6e184bfc58 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -32,6 +32,7 @@ module fms_diag_yaml_mod #ifdef use_yaml use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type, diag_yaml_files_obj_init, & NUM_SUB_REGION_ARRAY +use diag_data_mod, only: DIAG_NULL use yaml_parser_mod use mpp_mod @@ -40,6 +41,7 @@ module fms_diag_yaml_mod private public :: diag_yaml_object_init, diag_yaml_object_end +public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields !> @} integer, parameter :: basedate_size = 6 @@ -54,6 +56,8 @@ module fms_diag_yaml_mod contains procedure :: get_title !< Returns the title procedure :: get_basedate !< Returns the basedate array + procedure :: get_diag_files !< Returns the diag_files array + procedure :: get_diag_fields !< Returns the diag_field array end type diagYamlObject_type type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml @@ -62,9 +66,19 @@ module fms_diag_yaml_mod !> @{ contains +!> @brief gets the diag_yaml module variable +!! @return a copy of the diag_yaml module variable +function get_diag_yaml_obj() & +result(res) + type (diagYamlObject_type) :: res + + res = diag_yaml +end function get_diag_yaml_obj + !> @brief get the basedate of a diag_yaml type !! @return the basedate as an integer array -pure function get_basedate (diag_yaml) result (diag_basedate) +pure function get_basedate (diag_yaml) & +result (diag_basedate) class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return @@ -73,13 +87,34 @@ end function get_basedate !> @brief get the title of a diag_yaml type !! @return the title of the diag table as an allocated string -pure function get_title (diag_yaml) result (diag_title) +pure function get_title (diag_yaml) & + result (diag_title) class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml character(len=:),allocatable :: diag_title !< Basedate array result to return diag_title = diag_yaml%diag_title end function get_title +!> @brief get the diag_files of a diag_yaml type +!! @return the diag_files +pure function get_diag_files(diag_yaml) & +result(diag_files) + class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml + type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files!< History file info + + diag_files = diag_yaml%diag_files +end function get_diag_files + +!> @brief get the diag_fields of a diag_yaml type +!! @return the diag_fields +pure function get_diag_fields(diag_yaml) & +result(diag_fields) + class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml + type(diagYamlFilesVar_type), allocatable, dimension (:) :: diag_fields !< Diag fields info + + diag_fields = diag_yaml%diag_fields +end function get_diag_fields + !> @brief Uses the yaml_parser_mod to read in the diag_table and fill in the !! diag_yaml object subroutine diag_yaml_object_init @@ -114,9 +149,16 @@ subroutine diag_yaml_object_init nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i)) allocate(var_ids(nvars)) call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i)) + allocate(diag_yaml%diag_files(i)%file_varlist(nvars)) nvars_loop: do j = 1, nvars var_count = var_count + 1 + !> Save the filename in the diag_field type + diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(i)%file_fname + call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count)) + + !> Save the variable name in the diag_file type + diag_yaml%diag_files(i)%file_varlist(j) = diag_yaml%diag_fields(var_count)%var_varname enddo nvars_loop deallocate(var_ids) enddo nfiles_loop @@ -129,6 +171,7 @@ subroutine diag_yaml_object_end() integer :: i !< For do loops do i = 1, size(diag_yaml%diag_files, 1) + if(allocated(diag_yaml%diag_files(i)%file_varlist)) deallocate(diag_yaml%diag_files(i)%file_varlist) if(allocated(diag_yaml%diag_files(i)%file_global_meta)) deallocate(diag_yaml%diag_files(i)%file_global_meta) if(allocated(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)) & deallocate(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region) @@ -162,18 +205,27 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", fileobj%file_frequnit) call get_value_from_key(diag_yaml_id, diag_file_id, "freq", fileobj%file_freq) + call check_file_freq(fileobj) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit) + call check_file_time_units(fileobj) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "write_file", fileobj%string_file_write, is_optional=.true.) if (fileobj%string_file_write .eq. "false") fileobj%file_write = .false. call diag_get_value_from_key(diag_yaml_id, diag_file_id, "realm", fileobj%file_realm, is_optional=.true.) + call check_file_realm(fileobj) + call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", fileobj%file_new_file_freq_units, & is_optional=.true.) + call check_new_file_freq(fileobj) + call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.) call get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", fileobj%file_duration, is_optional=.true.) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", fileobj%file_duration_units, & - is_optional=.true.) + is_optional=.true.) + call check_file_duration(fileobj) nsubregion = 0 nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id) @@ -182,13 +234,19 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", fileobj%file_sub_region%grid_type) if (trim(fileobj%file_sub_region%grid_type) .eq. "latlon") then allocate(fileobj%file_sub_region%lat_lon_sub_region(8)) + fileobj%file_sub_region%lat_lon_sub_region = DIAG_NULL call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%lat_lon_sub_region) elseif (trim(fileobj%file_sub_region%grid_type) .eq. "index") then allocate(fileobj%file_sub_region%index_sub_region(8)) + fileobj%file_sub_region%index_sub_region = DIAG_NULL call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region) call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.) if (fileobj%file_sub_region%tile .eq. 0) call mpp_error(FATAL, "The tile number is required when defining a "//& "subregion. Check your subregion entry for "//trim(fileobj%file_fname)) + else + call mpp_error(FATAL, trim(fileobj%file_sub_region%grid_type)//" is not a valid region type. & + &The acceptable values are latlon and index. & + &Check your entry for file:"//trim(fileobj%file_fname)) endif elseif (nsubregion .ne. 0) then call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple region blocks") @@ -219,8 +277,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) subroutine fill_in_diag_fields(diag_file_id, var_id, field) integer, intent(in) :: diag_file_id !< Id of the file block in the yaml file integer, intent(in) :: var_id !< Id of the variable block in the yaml file - type(diagYamlFilesVar_type), intent(out) :: field !< diagYamlFilesVar_type obj to read the contents into - + type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into integer :: natt !< Number of attributes in variable integer :: var_att_id(1) !< Id of the variable attribute block @@ -232,8 +289,12 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field) field%var_write = .true. call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname) call diag_get_value_from_key(diag_file_id, var_id, "reduction", field%var_reduction) + call check_field_reduction(field) + call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module) call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind) + call check_field_kind(field) + call diag_get_value_from_key(diag_file_id, var_id, "write_var", field%string_var_write, is_optional=.true.) if (trim(field%string_var_write) .eq. "false") field%var_write = .false. @@ -313,6 +374,139 @@ function get_total_num_vars(diag_yaml_id, diag_file_ids) & end do end function +!> @brief This checks if the file frequency in a diag file is valid and crashes if it isn't +subroutine check_file_freq(fileobj) + type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check + + if (fileobj%file_freq < 1 ) & + call mpp_error(FATAL, "freq must be greater than 0. & + &Check you entry for"//trim(fileobj%file_fname)) + if(.not. is_valid_time_units(fileobj%file_frequnit)) & + call mpp_error(FATAL, trim(fileobj%file_frequnit)//" is not a valid file_frequnit. & + &The acceptable values are seconds, minuts, hours, days, months, years. & + &Check your entry for file:"//trim(fileobj%file_fname)) +end subroutine check_file_freq + +!> @brief This checks if the time unit in a diag file is valid and crashes if it isn't +subroutine check_file_time_units (fileobj) + type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK + + if(.not. is_valid_time_units(fileobj%file_timeunit)) & + call mpp_error(FATAL, trim(fileobj%file_timeunit)//" is not a valid time_unit. & + &The acceptable values are seconds, minuts, hours, days, months, years. & + &Check your entry for file:"//trim(fileobj%file_fname)) +end subroutine check_file_time_units + +!> @brief This checks if the realm in a diag file is valid and crashes if it isn't +subroutine check_file_realm(fileobj) + type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK + + select case (TRIM(fileobj%file_realm)) + case ("ATM", "OCN", "LND", "ICE", "") + case default + call mpp_error(FATAL, trim(fileobj%file_realm)//" is an invalid realm! & + &The acceptable values are ATM, OCN, LND, ICE. & + &Check your entry for file:"//trim(fileobj%file_fname)) + end select + +end subroutine check_file_realm + +!> @brief This checks if the new file frequency in a diag file is valid and crashes if it isn't +subroutine check_new_file_freq(fileobj) + type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check + + if (fileobj%file_new_file_freq > 0) then + if (trim(fileobj%file_new_file_freq_units) .eq. "") & + call mpp_error(FATAL, "new_file_freq_units is required if using new_file_freq. & + &Check your entry for file:"//trim(fileobj%file_fname)) + + if (.not. is_valid_time_units(fileobj%file_new_file_freq_units)) & + call mpp_error(FATAL, trim(fileobj%file_new_file_freq_units)//" is not a valid new_file_freq_units. & + &The acceptable values are seconds, minuts, hours, days, months, years. & + &Check your entry for file:"//trim(fileobj%file_fname)) + endif +end subroutine check_new_file_freq + +!> @brief This checks if the file duration in a diag file is valid and crashes if it isn't +subroutine check_file_duration(fileobj) + type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check + + if (fileobj%file_duration > 0) then + if(trim(fileobj%file_duration_units) .eq. "") & + call mpp_error(FATAL, "file_duration_units is required if using file_duration. & + &Check your entry for file:"//trim(fileobj%file_fname)) + + if (.not. is_valid_time_units(fileobj%file_duration_units)) & + call mpp_error(FATAL, trim(fileobj%file_duration_units)//" is not a valid file_duration_units. & + &The acceptable values are seconds, minuts, hours, days, months, years. & + &Check your entry for file:"//trim(fileobj%file_duration_units)) + endif +end subroutine check_file_duration + +!> @brief This checks if the kind of a diag field is valid and crashes if it isn't +subroutine check_field_kind(field) + type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into + + select case (TRIM(field%var_skind)) + case ("double", "float") + case default + call mpp_error(FATAL, trim(field%var_skind)//" is an invalid kind! & + &The acceptable values are double and float. & + &Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname)) + end select + +end subroutine check_field_kind + +!> @brief This checks if the reduction of a diag field is valid and crashes if it isn't +subroutine check_field_reduction(field) + type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into + + integer :: n_diurnal !< number of diurnal samples + integer :: pow_value !< The power value + integer :: ioerror !< io error status after reading in the diurnal samples + + n_diurnal = 0 + pow_value = 0 + ioerror = 0 + if (field%var_reduction(1:7) .eq. "diurnal") then + READ (UNIT=field%var_reduction(8:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) n_diurnal + if (ioerror .ne. 0) & + call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(field%var_reduction)) + if (n_diurnal .le. 0) & + call mpp_error(FATAL, "Diurnal samples should be greater than 0. & + & Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname)) + elseif (field%var_reduction(1:3) .eq. "pow") then + READ (UNIT=field%var_reduction(4:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) pow_value + if (ioerror .ne. 0) & + call mpp_error(FATAL, "Error getting the power value from "//trim(field%var_reduction)) + if (pow_value .le. 0) & + call mpp_error(FATAL, "The power value should be greater than 0. & + & Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname)) + else + select case (TRIM(field%var_reduction)) + case ("none", "average", "min", "max", "rms") + case default + call mpp_error(FATAL, trim(field%var_reduction)//" is an invalid reduction method! & + &The acceptable values are none, average, pow##, diurnal##, min, max, and rms. & + &Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname)) + end select + endif +end subroutine check_field_reduction + +!> @brief This checks if a time unit is valid +!! @return Flag indicating if the time units are valid +pure function is_valid_time_units(time_units) & +result(is_valid) + character(len=*), intent(in) :: time_units + logical :: is_valid + + select case (TRIM(time_units)) + case ("seconds", "minutes", "hours", "days", "months", "years") + is_valid = .true. + case default + is_valid = .false. + end select +end function is_valid_time_units #endif end module fms_diag_yaml_mod !> @} diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90 index e406885084..7cc6db38f3 100644 --- a/diag_manager/fms_diag_yaml_object.F90 +++ b/diag_manager/fms_diag_yaml_object.F90 @@ -99,6 +99,7 @@ module fms_diag_yaml_object_mod procedure :: get_file_duration_units procedure :: get_file_varlist procedure :: get_file_global_meta + procedure :: is_global_meta end type diagYamlFiles_type @@ -129,7 +130,7 @@ module fms_diag_yaml_object_mod procedure :: get_var_units procedure :: get_var_write procedure :: get_var_attributes - + procedure :: is_var_attributes end type diagYamlFilesVar_type contains @@ -239,6 +240,15 @@ pure function get_file_global_meta (diag_files_obj) result (res) character (:), allocatable :: res(:,:) !< What is returned res = diag_files_obj%file_global_meta end function get_file_global_meta +!> @brief Inquiry for whether file_global_meta is allocated +!! @return Flag indicating if file_global_meta is allocated +function is_global_meta(diag_files_obj) result(res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + logical :: res + res = .false. + if (allocated(diag_files_obj%file_global_meta)) & + res = .true. +end function !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -316,6 +326,15 @@ pure function get_var_attributes(diag_var_obj) result (res) character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned res = diag_var_obj%var_attributes end function get_var_attributes +!> @brief Inquiry for whether var_attributes is allocated +!! @return Flag indicating if var_attributes is allocated +function is_var_attributes(diag_var_obj) result(res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + logical :: res + res = .false. + if (allocated(diag_var_obj%var_attributes)) & + res = .true. +end function is_var_attributes !> @brief Initializes the non string values of a diagYamlFiles_type to its !! default values @@ -325,8 +344,7 @@ subroutine diag_yaml_files_obj_init(obj) obj%file_freq = 0 obj%file_write = .true. obj%file_duration = 0 - obj%file_sub_region%lat_lon_sub_region = -999. - obj%file_sub_region%index_sub_region = -999 + obj%file_new_file_freq = 0 obj%file_sub_region%tile = 0 end subroutine diag_yaml_files_obj_init diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 05fd840297..1c55871f00 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -29,11 +29,12 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \ - test_diag_dlinked_list + test_diag_dlinked_list test_diag_yaml # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 test_diag_manager_time_SOURCES = test_diag_manager_time.F90 +test_diag_yaml_SOURCES = test_diag_yaml.F90 test_diag_object_container_SOURCES = test_diag_object_container.F90 test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90 @@ -41,7 +42,14 @@ test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90 TESTS = test_diag_manager2.sh # Copy over other needed files to the srcdir -EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh +EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh check_crashes.sh -# Clean up -CLEANFILES = input.nml *.nc *.out diag_table +if SKIP_PARSER_TESTS +skipflag="skip" +else +skipflag="" +endif + +TESTS_ENVIRONMENT = parser_skip=${skipflag} + +CLEANFILES = *.yaml input.nml *.nc *.out diag_table diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh new file mode 100755 index 0000000000..da68fdf81f --- /dev/null +++ b/test_fms/diag_manager/check_crashes.sh @@ -0,0 +1,163 @@ +#!/bin/sh + +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/data_override directory. + +# Set common test settings. +. ../test_common.sh + +printf "&check_crashes_nml \n checking_crashes = .true. \n/" | cat > input.nml + +echo "Test 27: Missing tile when using the 'index' grid type" +touch input.nml +sed '/tile/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since 'tile' was missing and the 'index' grid type was used" + exit 3 +fi + +echo "Test 28: Missing new_file_freq_units when using new_file_freq_units" +touch input.nml +sed '/new_file_freq_units/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since 'new_file_freq_units' was missing and new_file_freq was used" + exit 3 +fi + +echo "Test 29: new_file_freq_units is not valid" +touch input.nml +sed 's/new_file_freq_units: hours/new_file_freq_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since 'new_file_freq_units' is not valid" + exit 3 +fi + +echo "Test 30: Missing file_duration_units when using file_duration" +touch input.nml +sed '/file_duration_units/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since 'file_duration_units' was missing and file_duration was used" + exit 3 +fi + +echo "Test 31: file_duration_units is not valid" +touch input.nml +sed 's/file_duration_units: hours/file_duration_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since 'file_duration_units' is not valid" + exit 3 +fi + +echo "Test 32: freq units is not valid" +touch input.nml +sed 's/freq_units: hours/freq_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the freq units is not valid" + exit 3 +fi + +echo "Test 33: freq is less than 0" +touch input.nml +sed 's/freq: 6/freq: -666/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since freq is not valid" + exit 3 +fi + +echo "Test 34: realm is not valid" +touch input.nml +sed 's/realm: ATM/realm: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since realm is not valid" + exit 3 +fi + +echo "Test 35: kind is not valid" +touch input.nml +sed 's/kind: float/kind: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the kind is not valid" + exit 3 +fi + +echo "Test 36: reduction is not valid" +touch input.nml +sed 's/reduction: average/reduction: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the reduction method is not valid" + exit 3 +fi + +echo "Test 37: diurnal samples is less than 0" +touch input.nml +sed 's/reduction: average/reduction: diurnal0/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the number of diurnal samples is less than 0" + exit 3 +fi + +echo "Test 38: diurnal samples is not an integer" +touch input.nml +sed 's/reduction: average/reduction: diurnal99r/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the number of diurnal samples is not valid" + exit 3 +fi + +echo "Test 39: power value is less than 0" +touch input.nml +sed 's/reduction: average/reduction: pow0/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the power value is less than" + exit 3 +fi + +echo "Test 40: power value is not an integer" +touch input.nml +sed 's/reduction: average/reduction: pow99r/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the power value is not valid" + exit 3 +fi + +echo "Test 41: the sub_region grid_type is not valid" +touch input.nml +sed 's/grid_type: latlon/grid_type: ice_cream/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml +run_test test_diag_yaml 1 $parser_skip && echo "It worked?" +if [ $? -eq 0 ]; then + echo "Test should have failed since the sub_region grid_type" + exit 3 +fi diff --git a/test_fms/diag_manager/diagTables/diag_table_yaml_26 b/test_fms/diag_manager/diagTables/diag_table_yaml_26 new file mode 100644 index 0000000000..d82038bd6a --- /dev/null +++ b/test_fms/diag_manager/diagTables/diag_table_yaml_26 @@ -0,0 +1,61 @@ +title: test_diag_manager +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: wild_card_name%4yr%2mo%2dy%2hr + freq: 6 + freq_units: hours + time_units: hours + unlimdim: time + new_file_freq: 6 + new_file_freq_units: hours + start_time: 2 1 1 0 0 0 + file_duration: 12 + file_duration_units: hours + write_file: false + realm: ATM + varlist: + - module: test_diag_manager_mod + var_name: sst + output_name: sst + reduction: average + kind: float + write_var: false + global_meta: + - is_a_file: true +- file_name: normal + freq: 24 + freq_units: days + time_units: hours + unlimdim: records + varlist: + - module: test_diag_manager_mod + var_name: sst + output_name: sst + reduction: average + kind: float + write_var: true + attributes: + - do_sst: .true. + sub_region: + - grid_type: latlon + dim1_begin: 64.0 + dim3_end: 20.0 +- file_name: normal2 + freq: 24 + freq_units: days + time_units: hours + unlimdim: records + write_file: true + varlist: + - module: test_diag_manager_mod + var_name: sstt + output_name: sstt + reduction: average + kind: float + long_name: S S T + sub_region: + - grid_type: index + tile: 1 + dim2_begin: 10 + dim2_end: 20 + dim1_begin: 10 diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index d424ec55d0..355912924a 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -102,6 +102,13 @@ touch input.nml cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table run_test test_diag_manager_time 1 +echo "Test 26: diag_yaml_init" +touch input.nml +cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 diag_table.yaml +run_test test_diag_yaml 1 $parser_skip + +. $top_srcdir/test_fms/diag_manager/check_crashes.sh + echo "Test container" rm -f input.nml diag_table touch input.nml diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90 new file mode 100644 index 0000000000..d939de7b91 --- /dev/null +++ b/test_fms/diag_manager/test_diag_yaml.F90 @@ -0,0 +1,311 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @brief This program tests the diag_yaml_object_init and diag_yaml_object_end subroutines +!! in fms_diag_yaml_mod +program test_diag_yaml + +#ifdef use_yaml +use FMS_mod, only: fms_init, fms_end +use fms_diag_yaml_mod +use fms_diag_yaml_object_mod +use mpp_mod +use platform_mod + +implicit none + +!< @brief Interface used to compare two different values +interface compare_result +subroutine compare_result_0d(key_name, res, expected_res) + character(len=*), intent(in) :: key_name !< Name of the key to compare + class(*), intent(in) :: res !< Value obtained from reading the file + class(*), intent(in) :: expected_res !< Value expected +end subroutine compare_result_0d + +subroutine compare_result_1d(key_name, res, expected_res) + character(len=*), intent(in) :: key_name !< Name of the key to compare + class(*), intent(in) :: res(:) !< Value obtained from reading the file + class(*), intent(in) :: expected_res(:) !< Value expected +end subroutine compare_result_1d +end interface compare_result + +type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init +type(diagYamlObject_type) :: ans !< expected diagYamlObject +logical :: checking_crashes = .false.!< Flag indicating that you are checking crashes +integer :: i !< For do loops +integer :: io_status !< The status after reading the input.nml + +type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml +type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml + +namelist / check_crashes_nml / checking_crashes + +call fms_init() + +read (input_nml_file, check_crashes_nml, iostat=io_status) +if (io_status > 0) call mpp_error(FATAL,'=>check_crashes: Error reading input.nml') + +call diag_yaml_object_init + +my_yaml = get_diag_yaml_obj() + +if (.not. checking_crashes) then + call compare_result("base_date", my_yaml%get_basedate(), (/2, 1, 1, 0, 0 , 0 /)) + call compare_result("title", my_yaml%get_title(), "test_diag_manager") + + diag_files = my_yaml%get_diag_files() + call compare_result("nfiles", size(diag_files), 3) + call compare_diag_files(diag_files) + + diag_fields = my_yaml%get_diag_fields() + call compare_result("nfields", size(diag_fields), 3) + call compare_diag_fields(diag_fields) + +endif +deallocate(diag_files) +deallocate(diag_fields) + +call diag_yaml_object_end + +call fms_end() + +contains + +!> @brief Compares a diagYamlFilesVar_type with the expected result and +!! crashes if they don't match +subroutine compare_diag_fields(res) + type(diagYamlFilesVar_type), intent(in) :: res(:) !< diag_field info read from yaml file + character (len=255), dimension(:, :), allocatable :: var_attributes !< Variable attributes + + call compare_result("var_fname 1", res(1)%get_var_fname(), "wild_card_name%4yr%2mo%2dy%2hr") + call compare_result("var_fname 2", res(2)%get_var_fname(), "normal") + call compare_result("var_fname 3", res(3)%get_var_fname(), "normal2") + + call compare_result("var_varname 1", res(1)%get_var_varname(), "sst") + call compare_result("var_varname 2", res(2)%get_var_varname(), "sst") + call compare_result("var_varname 3", res(3)%get_var_varname(), "sstt") + + call compare_result("var_reduction 1", res(1)%get_var_reduction(), "average") + call compare_result("var_reduction 2", res(2)%get_var_reduction(), "average") + call compare_result("var_reduction 3", res(3)%get_var_reduction(), "average") + + call compare_result("var_module 1", res(1)%get_var_module(), "test_diag_manager_mod") + call compare_result("var_module 2", res(2)%get_var_module(), "test_diag_manager_mod") + call compare_result("var_module 3", res(3)%get_var_module(), "test_diag_manager_mod") + + call compare_result("var_skind 1", res(1)%get_var_skind(), "float") + call compare_result("var_skind 2", res(2)%get_var_skind(), "float") + call compare_result("var_skind 3", res(3)%get_var_skind(), "float") + + call compare_result("var_write 1", res(1)%get_var_write(), .false.) + call compare_result("var_write 2", res(2)%get_var_write(), .true.) + call compare_result("var_write 3", res(3)%get_var_write(), .true.) + + call compare_result("var_outname 1", res(1)%get_var_outname(), "sst") + call compare_result("var_outname 2", res(2)%get_var_outname(), "sst") + call compare_result("var_outname 3", res(3)%get_var_outname(), "sstt") + + call compare_result("var_longname 1", res(1)%get_var_longname(), "") + call compare_result("var_longname 2", res(2)%get_var_longname(), "") + call compare_result("var_longname 3", res(3)%get_var_longname(), "S S T") + + if (res(1)%is_var_attributes()) call mpp_error(FATAL, "The variable attributes for the first file was set?") + + var_attributes = res(2)%get_var_attributes() + if (.not. allocated(var_attributes)) call mpp_error(FATAL, "The variable attributes for the second file was not set") + call compare_result("var attributes key", var_attributes(1,1), "do_sst") + call compare_result("var attributes value", var_attributes(1,2), ".true.") + deallocate(var_attributes) + + if (res(3)%is_var_attributes()) call mpp_error(FATAL, "The variable attributes for the third file was set?") + +end subroutine + +!> @brief Compares a diagYamlFiles_type with the expected result and +!! crashes if they don't match +subroutine compare_diag_files(res) + type(diagYamlFiles_type), intent(in) :: res(:) !< diag_file info read from yaml file + + character (len=255), dimension(:), allocatable :: varlist !< List of variables + character (len=255), dimension(:, :), allocatable :: global_meta !< List of global meta + + call compare_result("file_fname 1", res(1)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr") + call compare_result("file_fname 2", res(2)%get_file_fname(), "normal") + call compare_result("file_fname 3", res(3)%get_file_fname(), "normal2") + + call compare_result("file_freq 1", res(1)%get_file_freq(), 6) + call compare_result("file_freq 2", res(2)%get_file_freq(), 24) + call compare_result("file_freq 3", res(3)%get_file_freq(), 24) + + call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), "hours") + call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), "days") + call compare_result("file_frequnit 3", res(3)%get_file_frequnit(), "days") + + call compare_result("file_timeunit 1", res(1)%get_file_timeunit(), "hours") + call compare_result("file_timeunit 2", res(2)%get_file_timeunit(), "hours") + call compare_result("file_timeunit 3", res(3)%get_file_timeunit(), "hours") + + call compare_result("file_unlimdim 1", res(1)%get_file_unlimdim(), "time") + call compare_result("file_unlimdim 2", res(2)%get_file_unlimdim(), "records") + call compare_result("file_unlimdim 3", res(3)%get_file_unlimdim(), "records") + + call compare_result("file_realm 1", res(1)%get_file_realm(), "ATM") + call compare_result("file_realm 2", res(2)%get_file_realm(), "") + call compare_result("file_realm 3", res(3)%get_file_realm(), "") + + call compare_result("file_write 1", res(1)%get_file_write(), .false.) + call compare_result("file_write 2", res(2)%get_file_write(), .true.) + call compare_result("file_write 3", res(3)%get_file_write(), .true.) + + call compare_result("file_new_file_freq 1", res(1)%get_file_new_file_freq(), 6) + call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), 0) + call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), 0) + + call compare_result("file_new_file_freq_units 1", res(1)%get_file_new_file_freq_units(), "hours") + call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), "") + call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), "") + + call compare_result("file_duration 1", res(1)%get_file_duration(), 12) + call compare_result("file_duration 2", res(2)%get_file_duration(), 0) + call compare_result("file_duration 3", res(3)%get_file_duration(), 0) + + call compare_result("file_duration_units 1", res(1)%get_file_duration_units(), "hours") + call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), "") + call compare_result("file_duration_units 3", res(3)%get_file_duration_units(), "") + + call compare_result("file_start_time 1", res(1)%get_file_start_time(), "2 1 1 0 0 0") + call compare_result("file_start_time 2", res(2)%get_file_start_time(), "") + call compare_result("file_start_time 3", res(3)%get_file_start_time(), "") + + varlist = res(1)%get_file_varlist() + if (.not. allocated(varlist)) call mpp_error(FATAL, "The varlist for the first file was not set") + call compare_result("number_variables 1", size(varlist), 1) + call compare_result("varlist 1", varlist(1), "sst") + deallocate(varlist) + + varlist = res(2)%get_file_varlist() + if (.not. allocated(varlist)) call mpp_error(FATAL, "The varlist for the first file was not set") + call compare_result("number_variables 2", size(varlist), 1) + call compare_result("varlist 2", varlist(1), "sst") + deallocate(varlist) + + varlist = res(3)%get_file_varlist() + if (.not. allocated(varlist)) call mpp_error(FATAL, "The varlist for the first file was not set") + call compare_result("number_variables 3", size(varlist), 1) + call compare_result("varlist 3", varlist(1), "sstt") + deallocate(varlist) + + global_meta= res(1)%get_file_global_meta() + if (.not. allocated(global_meta)) call mpp_error(FATAL, "The global meta for the first file was not set") + call compare_result("attributes key", global_meta(1,1), "is_a_file") + call compare_result("attributes value", global_meta(1,2), "true") + deallocate(global_meta) + + if (res(2)%is_global_meta()) call mpp_error(FATAL, "The global meta for the second file was set?") + if (res(3)%is_global_meta()) call mpp_error(FATAL, "The global meta for the third file was set?") + +end subroutine compare_diag_files + +#endif +end program test_diag_yaml + +#ifdef use_yaml +!< @brief Compare a key value with the expected result +subroutine compare_result_0d(key_name, res, expected_res) + use platform_mod + use mpp_mod + character(len=*), intent(in) :: key_name !< Name of the key to compare + class(*), intent(in) :: res !< Value obtained from reading the file + class(*), intent(in) :: expected_res !< Value expected + + print *, "Comparing ", trim(key_name) + select type(res) + type is(character(len=*)) + select type(expected_res) + type is(character(len=*)) + if(trim(res) .ne. trim(expected_res)) & + call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. "//trim(res)//" ne "//& + trim(expected_res)//".") + end select + type is (integer(kind=i4_kind)) + select type(expected_res) + type is(integer(kind=i4_kind)) + if (res .ne. expected_res) then + print *, res, " ne ", expected_res + call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result.") + endif + end select + type is (logical) + select type(expected_res) + type is(logical) + if ((res .and. .not. expected_res) .or. (.not. res .and. expected_res)) then + print*, res, " ne ", expected_res + call mpp_error(FATAL, "Error!:"//trim(key_name)//" is not the expected result") + endif + end select + end select + +end subroutine compare_result_0d + +!< @brief Compare a 1d key value with the expected result +subroutine compare_result_1d(key_name, res, expected_res) + use platform_mod + use mpp_mod + character(len=*), intent(in) :: key_name !< Name of the key to compare + class(*), intent(in) :: res(:) !< Value obtained from reading the file + class(*), intent(in) :: expected_res(:) !< Value expected + + integer :: i + + print *, "Comparing ", trim(key_name) + + select type(res) + type is (integer(kind=i4_kind)) + select type(expected_res) + type is (integer(kind=i4_kind)) + do i = 1, size(res,1) + if( res(i) .ne. expected_res(i)) then + print *, res, " ne ", expected_res + call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ") + endif + enddo + end select + type is (real(kind=r4_kind)) + select type(expected_res) + type is (real(kind=r4_kind)) + do i = 1, size(res,1) + if( res(i) .ne. expected_res(i)) then + print *, res, " ne ", expected_res + call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ") + endif + enddo + end select + type is (real(kind=r8_kind)) + select type(expected_res) + type is (real(kind=r8_kind)) + do i = 1, size(res,1) + if( res(i) .ne. expected_res(i)) then + print *, res, " ne ", expected_res + call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ") + endif + enddo + end select + end select +end subroutine compare_result_1d +#endif From 08205c6344dc779b854e457f2e27a6e2231f3144 Mon Sep 17 00:00:00 2001 From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com> Date: Mon, 7 Feb 2022 13:35:16 -0500 Subject: [PATCH 020/142] Dm get fns (#885) * Changes fms_diag_object to fmsDiagObject_type * Removes the multi-dimensional type extentions that will no be used * Uses a class(*) variable for missing_value and data_RANGE Fills in CMOR_MISSING_VALUE for missing_value if none is given Adds rountines for fmsDiagObject_type * Puts result for get_* functions on its own line in diag_object * Adds brief doxygen to get_* functions in diag_object * Updates comments on get functions in diag object Makes all integer get functions return diag_null if the variable is not allocated * Sets up parmeter diag_null_string as a single empty space * Adds is_ functions for logical variables in diag object --- diag_manager/diag_data.F90 | 1 + diag_manager/fms_diag_object.F90 | 400 ++++++++++++++++++++++++++++--- 2 files changed, 368 insertions(+), 33 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index a2726de407..d381981d64 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -66,6 +66,7 @@ MODULE diag_data_mod ! Specify storage limits for fixed size tables used for pointers, etc. integer, parameter :: diag_null = -999 !< Integer represening NULL in the diag_object + character(len=1), parameter :: diag_null_string = " " integer, parameter :: diag_not_found = -1 integer, parameter :: diag_not_registered = 0 integer, parameter :: diag_registered_id = 10 diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 9c3c8b7e09..cc8c028174 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -7,7 +7,7 @@ module fms_diag_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. -use diag_data_mod, only: diag_null +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 use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id @@ -35,8 +35,8 @@ module fms_diag_object_mod integer, allocatable, private :: diag_id !< unique id for varable class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the !! file objects for this variable - character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable - logical, private :: static !< true is this is a static var + character(len=:), allocatable, dimension(:) :: metadata !< metadata for the variable + 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 :: local !< If the output is local @@ -60,15 +60,8 @@ module fms_diag_object_mod integer, allocatable, private :: tile_count !< The number of tiles integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs integer, allocatable, private :: area, volume !< The Area and Volume - real, private :: missing_value !< Holds a missing value if none given - integer(kind=I4_KIND), allocatable, private :: i4missing_value !< The missing i4 fill value - integer(kind=I8_KIND), allocatable, private :: i8missing_value !< The missing i8 fill value - real(kind=R4_KIND), allocatable, private :: r4missing_value !< The missing r4 fill value - real(kind=R8_KIND), allocatable, private :: r8missing_value !< The missing r8 fill value - integer(kind=I4_KIND), allocatable,dimension(:) :: i4data_RANGE !< The range of i4 data - integer(kind=I8_KIND), allocatable,dimension(:) :: i8data_RANGE !< The range of i8 data - real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data - real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data + class(*), allocatable, private :: missing_value !< The missing fill value + class(*), allocatable, private :: data_RANGE !< The range of the variable data type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object !> \brief Extends the variable object to work with multiple types of data class(*), allocatable :: vardata0 @@ -88,15 +81,41 @@ module fms_diag_object_mod procedure :: copy => copy_diag_obj procedure :: register => fms_register_diag_field_obj !! Merely initialize fields. procedure :: setID => set_diag_id - procedure :: is_registered => diag_ob_registered 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 :: get_vartype => diag_obj_get_vartype - procedure :: get_varname => diag_obj_get_varname - + procedure :: is_mask_variant => get_mask_variant + procedure :: is_local => get_local +! Get functions + procedure :: get_diag_id => fms_diag_get_id + procedure :: get_metadata + 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_err_msg + procedure :: get_interp_method + procedure :: get_frequency + procedure :: get_output_units + procedure :: get_t + procedure :: get_tile_count + procedure :: get_axis_ids + 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 fmsDiagObject_type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type(fmsDiagObject_type) :: null_ob @@ -201,20 +220,28 @@ subroutine fms_register_diag_field_obj & if (present(missing_value)) then select type (missing_value) type is (integer(kind=i4_kind)) - dobj%i4missing_value = missing_value + allocate(integer(kind=i4_kind) :: dobj%missing_value) + dobj%missing_value = missing_value type is (integer(kind=i8_kind)) - dobj%i8missing_value = missing_value + allocate(integer(kind=i8_kind) :: dobj%missing_value) + dobj%missing_value = missing_value type is (real(kind=r4_kind)) - dobj%r4missing_value = missing_value + allocate(integer(kind=r4_kind) :: dobj%missing_value) + dobj%missing_value = missing_value type is (real(kind=r8_kind)) - dobj%r8missing_value = missing_value + 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 - dobj%missing_value = DIAG_NULL + allocate(real :: dobj%missing_value) + select type (miss => dobj%missing_value) + type is (real) + miss = real(CMOR_MISSING_VALUE) + end select endif ! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind @@ -324,6 +351,7 @@ subroutine copy_diag_obj(objin , objout) 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 @@ -396,17 +424,323 @@ function diag_obj_is_static (obj) result (rslt) rslt = obj%static end function diag_obj_is_static -function diag_obj_get_vartype (obj) result (rslt) - class(fmsDiagObject_type), intent(in) :: obj - integer :: rslt - rslt = obj%vartype -end function diag_obj_get_vartype - -function diag_obj_get_varname(obj) result (rslt) - class(fmsDiagObject_type), intent(in) :: obj - character(len=len(obj%varname)) :: rslt - rslt = obj%varname -end function diag_obj_get_varname +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Get functions + +!> @brief Gets metedata +!! @return copy of metadata string array, or a single space if metadata is not allocated +function get_metadata (obj) & +result(rslt) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + character(len=:), allocatable, dimension(:) :: rslt + if (allocated(obj%metadata)) then + allocate(character(len=(len(obj%metadata(1)))) :: rslt (size(obj%metadata)) ) + rslt = obj%metadata + else + allocate(character(len=1) :: rslt(1:1)) + rslt = diag_null_string + endif +end function get_metadata +!> @brief Gets static +!! @return copy of variable static +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 err_msg +!! @return copy of The error message stored in err_msg or an empty string if not allocated +function get_err_msg (obj) & +result(rslt) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + character(len=:), allocatable :: rslt + if (allocated(obj%err_msg)) then + rslt = obj%err_msg + else + rslt = diag_null_string + endif +end function get_err_msg +!> @brief Gets interp_method +!! @return copy of The interpolation method or an empty string if not allocated +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 +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 +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 +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 +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 axis_ids +!! @return copy of The axis IDs array or a diag_null if no axis IDs are set +function get_axis_ids (obj) & +result(rslt) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + integer, allocatable, dimension(:) :: rslt + if (allocated(obj%axis_ids)) then + allocate(rslt(size(obj%axis_ids))) + rslt = obj%axis_ids + else + allocate(rslt(1)) + rslt = diag_null + endif +end function get_axis_ids +!> @brief Gets area +!! @return copy of the area or diag_null if not allocated +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 +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) + rslt = r + type is (integer(kind=i8_kind)) + allocate (integer(kind=i8_kind) :: rslt) + rslt = r + type is (real(kind=r4_kind)) + allocate (integer(kind=i4_kind) :: rslt) + rslt = r + type is (real(kind=r8_kind)) + allocate (integer(kind=i4_kind) :: rslt) + 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 end module fms_diag_object_mod From 1e6cb523f351d75d3f9e0cffb5780dd739a05f3f Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Mon, 7 Feb 2022 13:37:31 -0500 Subject: [PATCH 021/142] diag_manager ontainer and linked list -test core dump fixes and more (#888) * Initial commit of the fms_diag_object_container. Includes the underlying linked_list library, some changes to diag_manger to initialize the container and to use the container upon field registration, related Makefile.am changes. * Modified diag object iterator to fix casting compilation error on CI system. * Initial modificationss in response to a review by Tom Robinsom on 12/7/01. Mostly documentation, logging, and type name improvements. * Experimenting with documentation annotations. * Added test of fms_diag_object_container class. Further changes to follow convention and documentation. * Corrected script calling unit test. Added todo in fms_diag_yaml.F90. * Cleaned up test of container. * Addded a "TODO:" to fms_diag_yaml.F90, function is filed type null. * Modified new files and unit test for further compliance with coding standards * Renamed the linked list mod. Corrected CMakeList.txtx and a Makefile.am. * Renamed linked list mod. Changed a Makefile.am. * Fixed CMakeLists.txt. * Mods to CMakeLIst.txt. Includes adding parser dir files. * Fixing typo in CMakeLists.txt * Many comments and documentation chages based on Tom R's 2nd review. * Adds annotations @addtogroup and @{ to the diag object container mod and the linked list mod. * Added comments for the "this" variable. Nods to use "!<" for var comments. * Further doxygen related improvements. Some improvements on on calss access (private/public) lables. * Five chages of list node instance declarations from class to node to compile on Intel. * One change from type to class for an interator instance. Some comment updates. * Added test_diag_dlinked_list.F90. Modified memeber data/access in several in several types. Improved several comments. * Improved or added several comments. * Removed vs code related files. * Removing extraneous return statement in test_diag_dlinked_list.F90. * Improved test_diag_dlinked_list.F90, both code and comments. * Removed duplicate yaml_parser.F90 from CMakeLists.txt. * Incorporates changes based on Tom R's latest review. * Includes some doxygen related changes requested by Ryan M. * Skipping linked list and the container tests by adding skip arg to calls in test_diaf_manager2.sh * Fixes the core dump of test_diag_dlinked_list. Also does some cleanup of the linked list and container classes, and their unit tests. * Improved comments, especially destructor and clear function. * Modified diag_manager to the containers initialize routine. * Post review making sure member vars are private. * Renamed linked list node member "data" to "data_ptr". --- diag_manager/diag_manager.F90 | 3 +- diag_manager/fms_diag_dlinked_list.F90 | 509 +++++++++--------- diag_manager/fms_diag_object_container.F90 | 60 ++- .../diag_manager/test_diag_dlinked_list.F90 | 123 ++--- test_fms/diag_manager/test_diag_manager2.sh | 2 +- .../test_diag_object_container.F90 | 45 +- 6 files changed, 390 insertions(+), 352 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index eb6ae66b0a..138a791fde 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -3734,7 +3734,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) END IF !!Create the diag_object container; Its a singleton in the diag_data mod - the_diag_object_container = FmsDiagObjectContainer_t() + allocate(the_diag_object_container) + call the_diag_object_container%initialize() module_is_initialized = .TRUE. ! create axis_id for scalars here diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90 index 99b4fb09ad..850a106b89 100644 --- a/diag_manager/fms_diag_dlinked_list.F90 +++ b/diag_manager/fms_diag_dlinked_list.F90 @@ -41,282 +41,297 @@ !> @addtogroup fms_diag_dlinked_list_mod !> @{ MODULE fms_diag_dlinked_list_mod - USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE - implicit none - !!TODO: COnsider setting the access (public,private) to functions, etc. - !> The doubly-linked list node type. - type, public:: FmsDlListNode_t - private - class(*), pointer :: data => null() !< The data pointed to by the node. - type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node. - type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node. - end type FmsDlListNode_t + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE + implicit none + !> The doubly-linked list node type. + type, public:: FmsDlListNode_t + private + class(*), pointer :: data_ptr => null() !< The data pointed to by the node. + type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node. + type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node. + end type FmsDlListNode_t - !> Linked list iterator - type, public :: FmsDllIterator_t - private - type(FmsDlListNode_t), pointer :: current !< A pointer to the current node. - type(FmsDlListNode_t), pointer :: end !< A sentinel (non-data) node. - contains - procedure :: has_data => literator_has_data !< Function returns true is there is data in the iterator. - procedure :: next => literator_next !< Function moves the iterator to the next data element. - procedure :: get => literator_data !< Function return a pointer to the current data. - procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer. - end type FmsDllIterator_t + !> Linked list iterator + type, public :: FmsDllIterator_t + private + type(FmsDlListNode_t), pointer :: current=>null() !< A pointer to the current node. + type(FmsDlListNode_t), pointer :: end =>null() !< A sentinel (non-data) node. + contains + procedure :: has_data => literator_has_data !< Function returns true if there is data in the iterator. + procedure :: next => literator_next !< Function moves the iterator to the next data element. Used in + !< conjunction with function has_data(). + procedure :: get => literator_data !< Function return a pointer to the current data. Used in conjunction + !< with function has_data(). + procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer. + end type FmsDllIterator_t - !> The doubly-linked list type. Besides the member functions, see the - !! associated iterator class ( FmsDllIterator_t) for traversal, and note that - !! the default constructor is overriden with an interface of the same name. - type, public :: FmsDlList_t - private - type(FmsDlListNode_t), pointer :: head !< The sentinal (non-data) head node of the linked list. . - type(FmsDlListNode_t), pointer :: tail !< The sentinel (non-data) tail node of the linked list. - integer :: the_size !< The number of data elements in the linked list. - contains - procedure :: push_back => push_at_back - procedure :: pop_back => pop_at_back - procedure :: remove => remove_node - procedure :: get_literator => get_forward_literator - procedure :: size => get_size - procedure :: is_empty => is_size_zero - procedure :: clear => clear_all - final :: destructor - procedure :: insert => insert_data + !> The doubly-linked list type. Besides the member functions, see the + !! associated iterator class ( FmsDllIterator_t) for traversal, and note that + !! the default constructor is overriden with an interface of the same name. + type, public :: FmsDlList_t + private + type(FmsDlListNode_t), pointer :: head=>null() !< The sentinal (non-data) head node of the linked list. . + type(FmsDlListNode_t), pointer :: tail=>null() !< The sentinel (non-data) tail node of the linked list. + integer :: the_size !< The number of data elements in the linked list. + contains + procedure :: push_back => push_at_back + procedure :: pop_back => pop_at_back + procedure :: remove => remove_node + procedure :: get_literator => get_forward_literator + procedure :: size => get_size + procedure :: is_empty => is_size_zero + procedure :: clear => clear_all + procedure :: initialize => linked_list_initializer + final :: destructor + procedure :: insert => insert_data - end type FmsDlList_t + end type FmsDlList_t - interface FmsDlListNode_t - module procedure :: node_constructor - end interface FmsDlListNode_t + interface FmsDlList_t + module procedure :: linked_list_constructor + end interface FmsDlList_t - interface FmsDlList_t - module procedure :: linked_list_constructor - end interface FmsDlList_t - - interface FmsDllIterator_t - module procedure :: literator_constructor - end interface FmsDllIterator_t + interface FmsDllIterator_t + module procedure :: literator_constructor + end interface FmsDllIterator_t contains - !> @brief Insert data d in a new node to be placed in front of the - !! target node t_nd. - !! @return Returns an iterator that starts with the newly inserted node. - function insert_data( this, t_nd, d ) result(liter) - class(FmsDlList_t), intent(in out) :: this ! d - !! Insert nd into list so that list section [prev node <--> target node ] looks like - !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or - !! from "new nd" need to be set. Therefore : - !! a) The new nd's prev needs to be whatever was the targets prev: - nd%prev => t_nd%prev - !! b) New node nd's next is obviously the target node: - nd%next => t_nd - !! c) the next of the prev node needs to point to the new node nd: - t_nd%prev%next => nd - !! d) target node's prev needs to point to the new node : - t_nd%prev => nd - this%the_size = this%the_size + 1 - liter = FmsDllIterator_t(nd, this%tail) - end function insert_data + !> @brief Insert data d in a new node to be placed in front of the + !! target node t_nd. + !! @return Returns an iterator that starts with the newly inserted node. + function insert_data( this, t_nd, d ) result(liter) + class(FmsDlList_t), intent(in out) :: this ! d + !! Insert nd into list so that list section [prev node <--> target node ] looks like + !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or + !! from "new nd" need to be set. Therefore : + !! a) The new nd's prev needs to be whatever was the targets prev: + nd%prev => t_nd%prev + !! b) New node nd's next is obviously the target node: + nd%next => t_nd + !! c) the next of the prev node needs to point to the new node nd: + t_nd%prev%next => nd + !! d) target node's prev needs to point to the new node : + t_nd%prev => nd + this%the_size = this%the_size + 1 + liter = FmsDllIterator_t(nd, this%tail) + end function insert_data + + !> @brief Remove Node nd from the linked tree. + !! @return Return the iterator that begins with the next node after nd, and ends with + !! the list end node. Returns the list iterator if the node cannot be removed. + function remove_node( this, nd ) result( litr) + class(FmsDlList_t), intent(in out) :: this ! nd%next + nd%next%prev => nd%prev + deallocate(nd) + this%the_size = this%the_size - 1 + else + litr = this%get_literator() + endif + end function remove_node - !> @brief Remove Node nd from the linked tree. - !! @return Return the iterator that begins with the next node after nd, and ends with - !! the list end node. Returns the list iterator if the node cannot be removed. - function remove_node( this, nd ) result( litr) - class(FmsDlList_t), intent(in out) :: this ! nd%next - nd%next%prev => nd%prev - deallocate(nd) - this%the_size = this%the_size - 1 - else - litr = this%get_literator() - endif - end function remove_node + !> @brief Remove the tail (last data node) of the list. + !! @return Returns an iterator to the remaining list. + function pop_at_back (this ) result( liter ) + class(FmsDlList_t), intent(in out) :: this ! this%tail%prev + liter = this%remove( nd ) + else + liter = this%get_literator() + endif + end function pop_at_back - !> @brief Remove the tail (last data node) of the list. - !! @return Returns an iterator to the remaining list. - function pop_at_back (this ) result( liter ) - class(FmsDlList_t), intent(in out) :: this ! this%tail%prev - liter = this%remove( nd ) - else - liter = this%get_literator() - endif - end function pop_at_back + !> @brief Push (insert) data at the end of the list + !> @return Returns an iterator that starts at the tail of the list. + function push_at_back( this, d ) result(litr) + class(FmsDlList_t), intent(in out) :: this ! @brief Push (insert) data at the end of the list - !> @return Returns an iterator that starts at the tail of the list. - function push_at_back( this, d ) result(litr) - class(FmsDlList_t), intent(in out) :: this ! @brief Constructor for the linked list. + !! @return Returns a newly allocated linked list instance. + !! TODO: This function is not used since (observed on Intel compilers) with + !! a finalize keyword on the destructor, when this function returns and ll + !! goes out of scope, th allocations in initialized are undome + !! whether ot not ll is declared a pointer or allocatable + function linked_list_constructor () result (ll) + type(FmsDlList_t), pointer :: ll !< The resultant linked list to be reutrned. + allocate(ll) + call ll%initialize() + end function linked_list_constructor - !> @brief Constructor for the node_type - !! @return Returns a nully allocated node. - function node_constructor () result (nd) - type(FmsDlListNode_t), allocatable :: nd !< The allocated node. - allocate(nd) - nd%data => null() - nd%prev => null() - nd%next => null() - end function node_constructor + !> @brief Initializer for the linked list. + !! @return Returns a newly allocated linked list instance. + subroutine linked_list_initializer( this ) + class(FmsDlList_t), intent(inout) :: this ! this%tail + this%tail%prev => this%head + this%the_size = 0 + endif + end subroutine linked_list_initializer - !> @brief Constructor for the linked list. - !! @return Returns a newly allocated linked list instance. - function linked_list_constructor () result (ll) - type(FmsDlList_t), allocatable :: ll !< The resultant linked list to be reutrned. - allocate(ll) - allocate(ll%head) - allocate(ll%tail) - !!print *, 'associated(ll%head) :' , associated(ll%head), & - !! ' associated(ll%head) :' , associated(ll%head) - ll%head%next => ll%tail - ll%tail%prev => ll%head - ll%the_size = 0 - end function linked_list_constructor - !> @brief The list iterator constructor. - !! @return Returns a newly allocated list iterator. - function literator_constructor ( fnd, tnd ) result (litr) - type (FmsDlListNode_t), pointer :: fnd - !< The sentinal (non-data) "first node" of the iterator will be fnd - type (FmsDlListNode_t), pointer :: tnd - !< The sentinal (non-data) "last node" of the iterator will be tnd. - type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned. - allocate(litr) - litr%current => fnd - litr%end => tnd - end function literator_constructor + !> @brief The list iterator constructor. + !! @return Returns a newly allocated list iterator. + function literator_constructor ( fnd, tnd ) result (litr) + type (FmsDlListNode_t), pointer :: fnd + !< The sentinal (non-data) "first node" of the iterator will be fnd + type (FmsDlListNode_t), pointer :: tnd + !< The sentinal (non-data) "last node" of the iterator will be tnd. + type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned. + allocate(litr) + litr%current => fnd + litr%end => tnd + end function literator_constructor - !> @brief Getter for the size (the number of data elements) of the linked list. - !! @return Returns the size of the lined list. - function get_size (this) result (sz) - class(FmsDlList_t), intent(in out) :: this - ! @brief Getter for the size (the number of data elements) of the linked list. + !! @return Returns the size of the lined list. + function get_size (this) result (sz) + class(FmsDlList_t), intent(in out) :: this + ! @brief Determines if the size (number of data elements) of the list is zero. !! @return Returns true if there are zero (0) data elements in the list; false otherwise. - function is_size_zero (this) result (r) - class(FmsDlList_t), intent(in out) :: this - ! @brief Create and return a new forward iterator for the list. - !> @return Returns a forward iterator for the linked list. - function get_forward_literator(this) result (litr) - class(FmsDlList_t), intent(in) :: this ! @brief Create and return a new forward iterator for the list. + !> @return Returns a forward iterator for the linked list. + function get_forward_literator(this) result (litr) + class(FmsDlList_t), intent(in) :: this ! @brief Determine if the iterator has data. - !> @return Returns true iff the iterator has data. - function literator_has_data( this ) result( r ) - class(FmsDllIterator_t), intent(in) :: this - ! @brief Determine if the iterator has data. + !> @return Returns true iff the iterator has data. + function literator_has_data( this ) result( r ) + class(FmsDllIterator_t), intent(in) :: this + ! @brief Move the iterators current data node pointer to the next data node. - !! @return Returns a status of 0 if succesful, -1 otherwise. - function literator_next( this ) result( status ) - class(FmsDllIterator_t), intent(in out ) :: this - integer :: status !< The returned status. Failure possible is if iterator does not have data. - status = -1 - if(this%has_data() .eqv. .true.) then - this%current => this%current%next - status = 0 - endif - end function literator_next + !> @brief Move the iterators current data node pointer to the next data node. + !! @return Returns a status of 0 if succesful, -1 otherwise. + function literator_next( this ) result( status ) + class(FmsDllIterator_t), intent(in out ) :: this + integer :: status !< The returned status. Failure possible is if iterator does not have data. + status = -1 + if(this%has_data() .eqv. .true.) then + this%current => this%current%next + status = 0 + endif + end function literator_next - !> @brief Get the current data object pointed to by the iterator. - !! function does not allocate or assign the result if - !! the user mistakenly called it without data present. - !! @return Returns a pointer to the current data. - function literator_data( this ) result( rd ) - class(FmsDllIterator_t), intent(in) :: this ! null() - if (this%has_data() .eqv. .true.) then - rd => this%current%data - endif - end function literator_data + !> @brief Get the current data object pointed to by the iterator. + !! function does not allocate or assign the result if + !! the user mistakenly called it without data present. + !! @return Returns a pointer to the current data. + function literator_data( this ) result( rd ) + class(FmsDllIterator_t), intent(in) :: this ! null() + if (this%has_data() .eqv. .true.) then + rd => this%current%data_ptr + endif + end function literator_data -!> @brief Get the current data object pointed to by the iterator. - !! function does not allocate or assign the result if - !! the user mistakenly called it without data present. - !! @return Returns a pointer to the current data. - function get_current_node_ptr( this ) result( pn ) - class(FmsDllIterator_t), intent(in) :: this ! this%current - end function get_current_node_ptr + !> @brief Get the current data object pointed to by the iterator. + !! function does not allocate or assign the result if + !! the user mistakenly called it without data present. + !! @return Returns a pointer to the current data. + function get_current_node_ptr( this ) result( pn ) + class(FmsDllIterator_t), intent(in) :: this ! this%current + end function get_current_node_ptr - !> @brief Iterate over all the nodes, remove them and deallocate the client data - !! that the node was holding. - subroutine clear_all( this ) - class(FmsDlList_t), intent(inout) :: this ! this%head%next - iter = this%remove(nd) - pdata => iter%get() - if (associated(pdata) .eqv. .false.) then - call error_mesg ('doubly_linked_list:clear_all', & - 'linked list destructor containes unassociated data pointer', & - WARNING) - else - deallocate(pdata) + !> @brief Iterate over all the nodes and remove them. Also (by overridable default), it deallocates the + !! client data associated with the nodes. + subroutine clear_all( this, data_dealloc_flag) + class(FmsDlList_t), intent(inout) :: this !null() !< A pointer to the data. + logical :: data_dealloc_f !< Set to data_dealloc_flag if present, otherwise its .true. + ! + data_dealloc_f = .true. + if( PRESENT(data_dealloc_flag) ) then + data_dealloc_f = data_dealloc_flag endif - end do - end subroutine clear_all + do while( this% the_size /= 0) + nd => this%head%next + pdata => nd%data_ptr + iter = this%remove(nd) + if(data_dealloc_f .eqv. .true.) then + if (associated(pdata) .eqv. .false.) then + call error_mesg ('fms_diag_dlinked_list', & + 'In clear_all; linked node contains node with unassociated data pointer', & + WARNING) + else + deallocate(pdata) + endif + endif + end do + end subroutine clear_all - !> @brief A destructor that deallocates every node and each nodes data element. - subroutine destructor(this) + !> @brief A destructor that deallocates every node and each nodes data element. !Note + !! that for the data elements to not be de-allocated, function clear() (or clear_all() ) + !! with the appropriate arguments must be called. + subroutine destructor(this) type(FmsDlList_t) :: this !null() + deallocate(this%tail) + this%tail=>null() + end subroutine destructor end module fms_diag_dlinked_list_mod !> @} diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90 index b3fdae819c..fe71b7a6ef 100644 --- a/diag_manager/fms_diag_object_container.F90 +++ b/diag_manager/fms_diag_object_container.F90 @@ -56,13 +56,15 @@ MODULE fms_diag_object_container_mod !! type, public:: FmsDiagObjectContainer_t private - TYPE (FmsDlList_t), ALLOCATABLE :: the_linked_list !< This version based on the FDS linked_list. + TYPE (FmsDlList_t), pointer :: the_linked_list => null() !< This version based on the FDS linked_list. contains procedure :: insert => insert_diag_object procedure :: remove => remove_diag_object procedure :: find => find_diag_object procedure :: size => get_num_objects procedure :: iterator => get_iterator + procedure :: initialize => container_initializer + procedure :: clear => clear_all final :: destructor end type FmsDiagObjectContainer_t @@ -72,15 +74,13 @@ MODULE fms_diag_object_container_mod private type(FmsDllIterator_t) :: liter !< This version based on the FDS linked_list (and its iterator). contains - procedure :: has_data => literator_has_data - procedure :: next => literator_next - procedure :: get => literator_data + procedure :: has_data => literator_has_data !< Function returns true if there is data in the iterator. + procedure :: next => literator_next !< Function moves the iterator to the next data element. Used in + !< conjunction with function has_data(). + procedure :: get => literator_data !< Function return a pointer to the current data. Used in conjunction + !< with function has_data(). end type FmsDiagObjIterator_t - interface FmsDiagObjectContainer_t - module procedure :: diag_object_container_constructor - end interface FmsDiagObjectContainer_t - interface FmsDiagObjIterator_t module procedure :: diag_obj_iterator_constructor end interface FmsDiagObjIterator_t @@ -202,10 +202,21 @@ end function diag_obj_iterator_constructor function diag_object_container_constructor () result (doc) type(FmsDiagObjectContainer_t), allocatable :: doc !< The resultant container. allocate(doc) - doc%the_linked_list = FmsDlList_t() - !! print * , "In DOC constructor" + doc%the_linked_list => null() + allocate(doc%the_linked_list) + call doc%the_linked_list%initialize end function diag_object_container_constructor + subroutine container_initializer( this ) + class(FmsDiagObjectContainer_t), intent(inout) :: this + if( associated(this%the_linked_list) ) then + call error_mesg('fms_diag_object_container:','container is already initialized', WARNING) + else + allocate(this%the_linked_list) + call this%the_linked_list%initialize() + endif + end subroutine container_initializer + !> @brief Determines if there is more data that can be accessed via the iterator. !> @return Returns true iff more data can be accessed via the iterator. function literator_has_data( this ) result( r ) @@ -236,22 +247,41 @@ function literator_data( this ) result( rdo ) class(*), pointer :: gp !< A eneric typed object in the container. rdo => null() - gp => this%liter%get() + gp => this%liter%get() select type(gp) type is (fmsDiagObject_type) !! "type is", not the (polymorphic) "class is" rdo => gp class default - CALL error_mesg ('diag_object_container:literator_data', & - 'Data to be accessed via iterator is not of expected type.',FATAL) + call error_mesg ('fms_diag_object_container:', & + 'In literator_data, data to be accessed is not of expected type.',FATAL) end select end function literator_data - !> @brief The destructor for the container. + !> @brief Iterate over all the nodes and remove them. Also (by overridable default), it deallocates the + !! client data associated with the nodes. + subroutine clear_all( this, data_dealloc_flag ) + class(FmsDiagObjectContainer_t), intent(inout) :: this ! @brief A destructor that deallocates every node and each nodes data element. !Note + !! that for the data elements to not be de-allocated, function clear() with the + !! appropriate arguments must be called. subroutine destructor(this) type(FmsDiagObjectContainer_t) :: this !null() end subroutine destructor diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90 index 4dff25a97a..355733b6bd 100644 --- a/test_fms/diag_manager/test_diag_dlinked_list.F90 +++ b/test_fms/diag_manager/test_diag_dlinked_list.F90 @@ -33,10 +33,9 @@ !! class in the book ``Data Structures And Algorithm Analysis in C++", !! 3rd Edition, by Mark Allen Weiss. program test_diag_dlinked_list - use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING - use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated + use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated use mpp_io_mod, only: mpp_io_init - + use fms_mod, ONLY: error_mesg, FATAL,NOTE use fms_diag_object_mod, only : fmsDiagObject_type use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t @@ -45,7 +44,7 @@ program test_diag_dlinked_list !> @brief This class is the type for the data to insert in the linked list. type TestDummy_t integer :: id = 0 - character(len=20) :: name + real :: weight = 1000 end type TestDummy_t !! @@ -61,27 +60,27 @@ program test_diag_dlinked_list logical :: test_passed !< Flag indicating if the test_passed !! These fields below used to initialize diag object data. TBD integer :: id - character(:), allocatable :: mname, mname_pre !! - - test_passed = .true. !! will be set to false if there are any issues. - call mpp_init(mpp_init_test_requests_allocated) call mpp_io_init() call mpp_set_stack_size(145746) + call error_mesg("test_diag_linked_list", "Starting tests",NOTE) + + test_passed = .true. !! will be set to false if there are any issues. + !! Ids will initially be from 1 to num_objs, so : full_id_sum = (num_objs * (num_objs + 1)) / 2 - !!Create the list - list = FmsDlList_t() + !! Create the list + allocate(list) + call list%initialize() if( list%size() /= 0) then - test_passed = .false. - call mpp_error(FATAL, "list incorrect size. Expected 0 at start") + test_passed = .false. + call error_mesg("test_diag_linked_list", "list incorrect size. Expected 0 at start",FATAL) endif - mname_pre = "ATM" !! Initialize num_objs objects and insert into list one at a time. !! The loop iterator is same as id - created in order to facilitate @@ -90,9 +89,8 @@ program test_diag_dlinked_list !!Allocate on heap another test dummy object : allocate (p_td_obj) !! And set some of its dummy data : - call combine_str_int(mname_pre, id, mname) p_td_obj%id = id - p_td_obj%name = mname + p_td_obj%weight = id + 1000 !! And have the "Char(*) pointer also point to it: p_obj => p_td_obj @@ -100,14 +98,14 @@ program test_diag_dlinked_list iter = list%push_back( p_obj) if(iter%has_data() .eqv. .false. ) then test_passed = .false. - call mpp_error(FATAL, "List push_back error.") + call error_mesg("test_diag_dlinked_list", "List push_back error.",FATAL) endif enddo if( list%size() /= num_objs) then test_passed = .false. - call mpp_error(FATAL, "List has incorrect size after inserts.") + call error_mesg("test_diag_dlinked_list", "List has incorrect size after inserts.",FATAL) endif @@ -117,24 +115,27 @@ program test_diag_dlinked_list if( sum /= full_id_sum) then test_passed = .false. - call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected") + call error_mesg("test_diag_dlinked_list", & + &"Id sums via iteration over the list objects is not as expected",FATAL) endif if( list%size() /= num_objs) then test_passed = .false. - call mpp_error(FATAL, "The list size is not as expected post inserts.") + call error_mesg("test_diag_dlinked_list", & + &"The list size is not as expected post inserts.",FATAL) endif !! Test a removal from the back (id should be num_objs) p_obj => find_back_of_list( list) - iter = list%pop_back() + iter = list%pop_back() !! Note the client is resposible for managing memory of anything he explicitly !! removes from the list: deallocate(p_obj) sum = sum_ids_in_list ( list ) if( sum /= full_id_sum - num_objs ) then test_passed = .false. - call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected") + call error_mesg("test_diag_dlinked_list", & + &"Id sums via iteration over the list objects is not as expected",FATAL) endif !! Repeat - test removal from the back of list (should be (num_objs -1)). @@ -146,93 +147,81 @@ program test_diag_dlinked_list sum = sum_ids_in_list ( list ) if( sum /= (full_id_sum - num_objs - (num_objs -1) )) then test_passed = .false. - call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected") + call error_mesg("test_diag_dlinked_list", & + & "Id sums via iteration over the list objects is not as expected",FATAL) endif + !! List.clear() is called by the destructor automatically, but for further testing + !! we will use it to renove (and deallocate) the data nodes and associated data + !! of the list. call list%clear() if( list%size() /= 0) then test_passed = .false. - call mpp_error(FATAL, "List is incorrect size after clearing.") + call error_mesg("test_diag_dlinked_list", & + "List is incorrect size after clearing.",FATAL) endif - write (6,*) "Finishing diag_dlinked_list tests." - - !! the list has a finalize/destructor which will deallocate data that is still it list. - !! equivalent to calling list%clear() as above. + !! Allocated objects are deallocated automatically, but one can aslo make the call. deallocate(list) + call error_mesg('test_diag_dlinked_list', 'Test has finished',NOTE) + call MPI_finalize(ierr) CONTAINS - - !> @brief Cast the "class(*) input data to the expected type. - function get_typed_data( data_in ) result( rdo ) - class(*), intent(in), pointer :: data_in !< An input pointer to the class(*) object. - class(TestDummy_t), pointer :: rdo !< The resultant pointer to the expected underlying object type. - rdo => null() - - select type(data_in) + function get_typed_data( pci ) result( pdo ) + class(*), intent(in), pointer :: pci !< An input pointer to the class(*) data object. + class(TestDummy_t), pointer :: pdo !< The resultant pointer to the expected underlying object type. + ! + pdo => null() + select type(pci) type is (TestDummy_t) !! "type is", not the (polymorphic) "class is" - rdo => data_in + pdo => pci class default - call mpp_error(FATAL, "Data to access is not of expected type.",FATAL) + call error_mesg("test_diag_dlinked_list", & + & "Data to access is not of expected type.",FATAL) end select end function get_typed_data !> Calcualte the sum of the ids. !! Exercises iteration over the list. - function sum_ids_in_list (list) result (rsum) - type (FmsDlList_t), allocatable :: list !< The linked list instance + function sum_ids_in_list (the_list) result (rsum) + type (FmsDlList_t), intent(inout) , allocatable :: the_list !< The linked list instance integer :: rsum !< The resultant sum of ids class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list - type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object - class(*), pointer :: p_obj !< A pointer to a class(*) object - integer :: ic_status !< A list insertion status. + type (TestDummy_t), pointer:: p_td_obj => null() !< A pointer to a test_dummy object + class(*), pointer :: p_obj => null() !< A pointer to a class(*) object + integer :: ic_status !< A list insertion status. !! rsum = 0 - iter = list%get_literator() + iter = the_list%get_literator() do while( iter%has_data() .eqv. .true.) p_obj => iter%get() p_td_obj => get_typed_data (p_obj ) - id = p_td_obj%id - rsum = rsum + id + rsum = rsum + p_td_obj%id ic_status = iter%next() end do end function sum_ids_in_list - !> Calcualate the sum of the ids. This also is a kind of search function, + !> Find the past object in list. This also is a kind of search function, !! so if the provided wrapper is not used, you have to write your own. !! @return a pointer the object at the end of the list, or null if none - function find_back_of_list (list) result (p_rdo) - type (FmsDlList_t), allocatable :: list !< The linked list instance - class(TestDummy_t), pointer :: p_rdo !< The resultant back of list, + function find_back_of_list (the_list) result (pdo) + type (FmsDlList_t), intent(inout) , allocatable ::the_list !< The linked list instance + class(TestDummy_t), pointer :: pdo !< The resultant back of list, class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list - class(*), pointer :: p_obj !< A pointer to a class(*) object + class(*), pointer :: p_obj => null() !< A pointer to a class(*) object integer :: ic_status !< A list insertion status. !! - p_rdo => null() - iter = list%get_literator() + pdo=>null() + iter = the_list%get_literator() do while( iter%has_data() .eqv. .true.) p_obj => iter%get() - p_rdo => get_typed_data (p_obj ) + pdo => get_typed_data (p_obj ) ic_status = iter%next() end do end function find_back_of_list - subroutine combine_str_int (str, num, rs) - character(:), allocatable, intent (in):: str - integer , intent (in) :: num - character(:), allocatable, intent (out) :: rs - character(len_trim(str) + 8) :: tmp - - write (tmp, "(A4,I4)") str,num - tmp = trim(tmp) - rs = tmp - end subroutine combine_str_int - - end program test_diag_dlinked_list - - diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 355912924a..294e1d50ed 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -113,7 +113,7 @@ echo "Test container" rm -f input.nml diag_table touch input.nml cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table -run_test test_diag_object_container 1 skip +run_test test_diag_object_container 1 echo "Test linked list " rm -f input.nml diag_table diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90 index 9a5b8e3251..e55b3fa30b 100644 --- a/test_fms/diag_manager/test_diag_object_container.F90 +++ b/test_fms/diag_manager/test_diag_object_container.F90 @@ -24,9 +24,9 @@ !! functions being tested are insert, remove, and size. The use of the iterators !! is also being tested. program test_diag_obj_container - use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING - use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated + use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated use mpp_io_mod, only: mpp_io_init + use fms_mod, ONLY: error_mesg, FATAL,NOTE use fms_diag_object_mod, only : fmsDiagObject_type use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t @@ -55,17 +55,20 @@ program test_diag_obj_container !! - test_passed = .true. !! will be set to false if there are any issues. - call mpp_init(mpp_init_test_requests_allocated) call mpp_io_init() call mpp_set_stack_size(145746) + call error_mesg('test_diag_object_container', 'Test has started',NOTE) + + test_passed = .true. !! will be set to false if there are any issues. + !! Ids will initially be from 1 to num_objs, so : full_id_sum = (num_objs * (num_objs + 1)) / 2 !!Create the container - container = FmsDiagObjectContainer_t() + allocate(container) + call container%initialize() !!In diag_manager, one module level container may be used instead of a local one like above. @@ -85,7 +88,7 @@ program test_diag_obj_container if( container%size() /= 0) then test_passed = .false. - call mpp_error(FATAL, "Container incorrect size. Expected 0 at start") + call error_mesg('test_diag_object_container', 'Container incorrect size. Expected 0 at start',FATAL) endif mname_pre = "ATM" vname_pre = "xvar" @@ -102,27 +105,27 @@ program test_diag_obj_container ic_status = container%insert(pobj%get_id(), pobj) if(ic_status .ne. 0)then test_passed = .false. - call mpp_error(FATAL, "Container Insertion error.") + call error_mesg('test_diag_object_container', 'Container Insertion error.',FATAL) endif enddo if( container%size() /= num_objs) then test_passed = .false. - call mpp_error(FATAL, "Container has incorrect size after inserts.") + call error_mesg('test_diag_object_container', 'Container has incorrect size after inserts.',FATAL) endif !!Search the container for a an object of specified key iter = container%find(123) if ( iter%has_data() .eqv. .true. ) then test_passed = .false. - call mpp_error(FATAL, "Found in container unexpected object of id=123") + call error_mesg('test_diag_object_container', 'Found in container unexpected object of id=123',FATAL) endif !!Again, search the container for a an object of specified key iter = container%find(4) if (iter%has_data() .neqv. .true. ) then test_passed = .false. - call mpp_error(FATAL, "Did not find expected container object of id=4") + call error_mesg('test_diag_object_container', 'Did not find expected container object of id=4',FATAL) endif !! Iterate over all the objects in the container; @@ -138,12 +141,12 @@ program test_diag_obj_container if( sum /= full_id_sum) then test_passed = .false. - call mpp_error(FATAL, "Id sums via iteration over the container objects is not as expected") + call error_mesg('test_diag_object_container', 'Id sums via iteration over the container objects is not as expected',FATAL) endif if( container%size() /= num_objs) then test_passed = .false. - call mpp_error(FATAL, "The container size is not as expected post inserts.") + call error_mesg('test_diag_object_container', 'The container size is not as expected post inserts.',FATAL) endif @@ -154,12 +157,12 @@ program test_diag_obj_container !! Verify the removal , part 1: if ( iter%has_data() .eqv. .true.) then test_passed = .false. - call mpp_error(FATAL, "Found object of id = 4 after removing it") + call error_mesg('test_diag_object_container', 'Found object of id = 4 after removing it',FATAL) endif !! Verify the removal , part 2 : if (container%size() /= (num_objs - 1)) then test_passed = .false. - call mpp_error(FATAL,"The_container%size() \= num_obj -1 after a removal ") + call error_mesg('test_diag_object_container','The_container%size() \= num_obj -1 after a removal ',FATAL) endif !! Verify the removal , part 3 : @@ -175,7 +178,7 @@ program test_diag_obj_container end do if( sum /= full_id_sum - 4) then test_passed = .false. - call mpp_error(FATAL, "Container incorrect id sums post removal of 4") + call error_mesg('test_diag_object_container', 'Container incorrect id sums post removal of 4',FATAL) endif !! End test a removal **** @@ -183,13 +186,13 @@ program test_diag_obj_container iter = container%find(7) if (iter%has_data() .neqv. .true. ) then test_passed = .false. - call mpp_error(FATAL, "Container did not find object of id=7") + call error_mesg('test_diag_object_container', 'Container did not find object of id=7',FATAL) endif !! Check the find results more : pobj => iter%get() if(pobj%get_id() /= 7) then test_passed = .false. - call mpp_error(FATAL," Id of returned object was not 7 ") + call error_mesg('test_diag_object_container', 'Id of returned object was not 7 ',FATAL) endif !!TODO further access tests. @@ -209,13 +212,13 @@ program test_diag_obj_container if( container%size() /= 0) then test_passed = .false. - call mpp_error(FATAL, "Container is incorrect size after clearing.") + call error_mesg('test_diag_object_container', 'Container is incorrect size after clearing.',FATAL) endif - write (6,*) "Finishing diag_obj_container tests." + !! And the container has a finalize/destructor which will deallocate the list and data. + deallocate(container) - !! the container has a finalize/destructor which will -deallocate(container) + call error_mesg('test_diag_object_container', 'Test has finished',NOTE) call MPI_finalize(ierr) From 3b9dde3e4c140c31cbd82e28368eb1794adb3720 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Mon, 7 Feb 2022 14:27:44 -0500 Subject: [PATCH 022/142] Moves fms_diag_yaml_obj to fms_diag_yaml (#887) * moves fms_diag_yaml_object into fms_diag_yaml * update test to use diag_null * more comments + explicit use statements --- CMakeLists.txt | 1 - diag_manager/Makefile.am | 8 +- diag_manager/fms_diag_object.F90 | 6 +- diag_manager/fms_diag_yaml.F90 | 360 ++++++++++++++++++++++- diag_manager/fms_diag_yaml_object.F90 | 354 ---------------------- test_fms/diag_manager/test_diag_yaml.F90 | 10 +- 6 files changed, 366 insertions(+), 373 deletions(-) delete mode 100644 diag_manager/fms_diag_yaml_object.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index ed85a57c87..fa4b9e3a73 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -115,7 +115,6 @@ list(APPEND fms_fortran_src_files diag_manager/diag_util.F90 diag_manager/fms_diag_object.F90 diag_manager/fms_diag_yaml.F90 - diag_manager/fms_diag_yaml_object.F90 diag_manager/fms_diag_dlinked_list.F90 diag_manager/fms_diag_object_container.F90 drifters/cloud_interpolator.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index ab3148ae63..82c692e9bb 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -40,7 +40,6 @@ libdiag_manager_la_SOURCES = \ diag_util.F90 \ fms_diag_yaml.F90 \ fms_diag_object.F90 \ - fms_diag_yaml_object.F90 \ fms_diag_object_container.F90 \ fms_diag_dlinked_list.F90 @@ -50,10 +49,8 @@ diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODE diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_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_yaml_object_mod.$(FC_MODEXT) -fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) \ - fms_diag_yaml_object_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_yaml_mod.$(FC_MODEXT) fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ @@ -68,7 +65,6 @@ MODFILES = \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ - fms_diag_yaml_object_mod.$(FC_MODEXT) \ fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_object_mod.$(FC_MODEXT) \ fms_diag_dlinked_list_mod.$(FC_MODEXT) \ diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index cc8c028174..76a46834c6 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -13,7 +13,9 @@ module fms_diag_object_mod use diag_axis_mod, only: diag_axis_type use mpp_mod, only: fatal, note, warning, mpp_error -use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type +#ifdef use_yaml +use fms_diag_yaml_mod, only: diagYamlFiles_type, diagYamlFilesVar_type +#endif 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, & @@ -30,8 +32,10 @@ module fms_diag_object_mod !> \brief Object that holds all variable information type fmsDiagObject_type +#ifdef use_yaml type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table +#endif integer, allocatable, private :: diag_id !< unique id for varable class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the !! file objects for this variable diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 6e184bfc58..22d344ec39 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -30,11 +30,10 @@ !> @{ module fms_diag_yaml_mod #ifdef use_yaml -use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type, diag_yaml_files_obj_init, & - NUM_SUB_REGION_ARRAY -use diag_data_mod, only: DIAG_NULL -use yaml_parser_mod -use mpp_mod +use diag_data_mod, only: DIAG_NULL +use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, & + get_block_ids, get_key_value, get_key_ids, get_key_name +use mpp_mod, only: mpp_error, FATAL implicit none @@ -42,9 +41,116 @@ module fms_diag_yaml_mod public :: diag_yaml_object_init, diag_yaml_object_end public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields +public :: diagYamlFiles_type, diagYamlFilesVar_type !> @} integer, parameter :: basedate_size = 6 +integer, parameter :: NUM_SUB_REGION_ARRAY = 8 +integer, parameter :: MAX_STR_LEN = 255 + +!> @brief type to hold the sub region information about a file +type subRegion_type + character (len=:), allocatable :: grid_type !< Flag indicating the type of region, + !! acceptable values are "latlon" and "index" + real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region + !! to use if grid_type is set to "latlon" + !! [dim1_begin, dim1_end, dim2_begin, dim2_end, + !! dim3_begin, dim3_end, dim4_begin, dim4_end] + integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to + !! to use if grid_type is set to "index" + !! [dim1_begin, dim1_end, dim2_begin, dim2_end, + !! dim3_begin, dim3_end, dim4_begin, dim4_end] + integer :: tile !< Tile number of the sub region, required if using the "index" grid type + +end type subRegion_type + +!> @brief type to hold the diag_file information +type diagYamlFiles_type + character (len=:), private, allocatable :: file_fname !< file name + character (len=:), private, allocatable :: file_frequnit !< the frequency unit + integer, private :: file_freq !< the frequency of data + character (len=:), private, allocatable :: file_timeunit !< The unit of time + character (len=:), private, allocatable :: file_unlimdim !< The name of the unlimited dimension + logical, private :: file_write !< false if the user doesn't want to the file to be created + character (len=:), private, allocatable :: string_file_write !< false if the user doesn’t want the file to be + !! created (default is true). + character (len=:), private, allocatable :: file_realm !< The modeling realm that the variables come from + type(subRegion_type), private :: file_sub_region !< type containing info about the subregion, if any + integer, private :: file_new_file_freq !< Frequency for closing the existing file + character (len=:), private, allocatable :: file_new_file_freq_units !< Time units for creating a new file. + !! Required if “new_file_freq” used + character (len=:), private, allocatable :: file_start_time !< Time to start the file for the first time. Requires + !! “new_file_freq” + integer, private :: file_duration !< How long the file should receive data after start time + !! in “file_duration_units”.  This optional field can only + !! be used if the start_time field is present.  If this field + !! is absent, then the file duration will be equal to the + !! frequency for creating new files. + !! NOTE: The file_duration_units field must also be present if + !! this field is present. + character (len=:), private, allocatable :: file_duration_units !< The file duration units + !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length + character (len=MAX_STR_LEN), dimension(:), private, allocatable :: file_varlist !< An array of variable names + !! within a file + character (len=MAX_STR_LEN), dimension(:,:), private, allocatable :: file_global_meta !< Array of key(dim=1) + !! 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) + !! return copies of the member variables unless explicitly noted. + procedure :: get_file_fname + procedure :: get_file_frequnit + procedure :: get_file_freq + procedure :: get_file_timeunit + procedure :: get_file_unlimdim + procedure :: get_file_write + procedure :: get_file_realm + procedure :: get_file_sub_region + procedure :: get_file_new_file_freq + procedure :: get_file_new_file_freq_units + procedure :: get_file_start_time + procedure :: get_file_duration + procedure :: get_file_duration_units + procedure :: get_file_varlist + procedure :: get_file_global_meta + procedure :: is_global_meta + +end type diagYamlFiles_type + +!> @brief type to hold the info a diag_field +type diagYamlFilesVar_type + character (len=:), private, allocatable :: var_fname !< The field/diagnostic name + character (len=:), private, allocatable :: var_varname !< The name of the variable + character (len=:), private, allocatable :: var_reduction !< Reduction to be done on var + character (len=:), private, allocatable :: var_module !< The module that th variable is in + character (len=:), private, allocatable :: var_skind !< The type/kind of the variable + character (len=:), private, allocatable :: string_var_write !< false if the user doesn’t want the variable to be + !! written to the file (default: true). + logical, private :: var_write !< false if the user doesn’t want the variable to be + !! written to the file (default: true). + character (len=:), private, allocatable :: var_outname !< Name of the variable as written to the file + character (len=:), private, allocatable :: var_longname !< Overwrites the long name of the variable + character (len=:), private, allocatable :: var_units !< Overwrites the units + + !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length + character (len=MAX_STR_LEN), dimension (:, :), private, allocatable :: var_attributes !< Attributes to overwrite or + !! add from diag_yaml + contains + !> All getter functions (functions named get_x(), for member field named x) + !! return copies of the member variables unless explicitly noted. + procedure :: get_var_fname + procedure :: get_var_varname + procedure :: get_var_reduction + procedure :: get_var_module + procedure :: get_var_skind + procedure :: get_var_outname + procedure :: get_var_longname + procedure :: get_var_units + procedure :: get_var_write + procedure :: get_var_attributes + procedure :: is_var_attributes +end type diagYamlFilesVar_type !> @brief Object that holds the information of the diag_yaml !> @ingroup fms_diag_yaml_mod @@ -241,7 +347,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) fileobj%file_sub_region%index_sub_region = DIAG_NULL call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region) call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.) - if (fileobj%file_sub_region%tile .eq. 0) call mpp_error(FATAL, "The tile number is required when defining a "//& + if (fileobj%file_sub_region%tile .eq. DIAG_NULL) call mpp_error(FATAL, "The tile number is required when defining a "//& "subregion. Check your subregion entry for "//trim(fileobj%file_fname)) else call mpp_error(FATAL, trim(fileobj%file_sub_region%grid_type)//" is not a valid region type. & @@ -507,6 +613,248 @@ pure function is_valid_time_units(time_units) & is_valid = .false. end select end function is_valid_time_units + +!!!!!!! YAML FILE INQUIRIES !!!!!!! +!> @brief Inquiry for diag_files_obj%file_fname +!! @return file_fname of a diag_yaml_file obj +pure function get_file_fname (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_files_obj%file_fname +end function get_file_fname +!> @brief Inquiry for diag_files_obj%file_frequnit +!! @return file_frequnit of a diag_yaml_file_obj +pure function get_file_frequnit (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_files_obj%file_frequnit +end function get_file_frequnit +!> @brief Inquiry for diag_files_obj%file_freq +!! @return file_freq of a diag_yaml_file_obj +pure function get_file_freq(diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_freq +end function get_file_freq +!> @brief Inquiry for diag_files_obj%file_timeunit +!! @return file_timeunit of a diag_yaml_file_obj +pure function get_file_timeunit (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_files_obj%file_timeunit +end function get_file_timeunit +!> @brief Inquiry for diag_files_obj%file_unlimdim +!! @return file_unlimdim of a diag_yaml_file_obj +pure function get_file_unlimdim(diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_files_obj%file_unlimdim +end function get_file_unlimdim +!> @brief Inquiry for diag_files_obj%file_write +!! @return file_write of a diag_yaml_file_obj +pure function get_file_write(diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + logical :: res !< What is returned + res = diag_files_obj%file_write +end function get_file_write +!> @brief Inquiry for diag_files_obj%file_realm +!! @return file_realm of a diag_yaml_file_obj +pure function get_file_realm(diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (:), allocatable :: res !< What is returned + res = diag_files_obj%file_realm +end function get_file_realm +!> @brief Inquiry for diag_files_obj%file_subregion +!! @return file_sub_region of a diag_yaml_file_obj +pure function get_file_sub_region (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + type(subRegion_type) :: res !< What is returned + res = diag_files_obj%file_sub_region +end function get_file_sub_region +!> @brief Inquiry for diag_files_obj%file_new_file_freq +!! @return file_new_file_freq of a diag_yaml_file_obj +pure function get_file_new_file_freq(diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_new_file_freq +end function get_file_new_file_freq +!> @brief Inquiry for diag_files_obj%file_new_file_freq_units +!! @return file_new_file_freq_units of a diag_yaml_file_obj +pure function get_file_new_file_freq_units (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (:), allocatable :: res !< What is returned + res = diag_files_obj%file_new_file_freq_units +end function get_file_new_file_freq_units +!> @brief Inquiry for diag_files_obj%file_start_time +!! @return file_start_time of a diag_yaml_file_obj +pure function get_file_start_time (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_files_obj%file_start_time +end function get_file_start_time +!> @brief Inquiry for diag_files_obj%file_duration +!! @return file_duration of a diag_yaml_file_obj +pure function get_file_duration (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + integer :: res !< What is returned + res = diag_files_obj%file_duration +end function get_file_duration +!> @brief Inquiry for diag_files_obj%file_duration_units +!! @return file_duration_units of a diag_yaml_file_obj +pure function get_file_duration_units (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (:), allocatable :: res !< What is returned + res = diag_files_obj%file_duration_units +end function get_file_duration_units +!> @brief Inquiry for diag_files_obj%file_varlist +!! @return file_varlist of a diag_yaml_file_obj +pure function get_file_varlist (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (:), allocatable :: res(:) !< What is returned + res = diag_files_obj%file_varlist +end function get_file_varlist +!> @brief Inquiry for diag_files_obj%file_global_meta +!! @return file_global_meta of a diag_yaml_file_obj +pure function get_file_global_meta (diag_files_obj) & +result (res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + character (:), allocatable :: res(:,:) !< What is returned + res = diag_files_obj%file_global_meta +end function get_file_global_meta +!> @brief Inquiry for whether file_global_meta is allocated +!! @return Flag indicating if file_global_meta is allocated +function is_global_meta(diag_files_obj) & + result(res) + class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried + logical :: res + res = .false. + if (allocated(diag_files_obj%file_global_meta)) & + res = .true. +end function +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!! YAML VAR INQUIRIES !!!!!!! +!> @brief Inquiry for diag_yaml_files_var_obj%var_fname +!! @return var_fname of a diag_yaml_files_var_obj +pure function get_var_fname (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_fname +end function get_var_fname +!> @brief Inquiry for diag_yaml_files_var_obj%var_varname +!! @return var_varname of a diag_yaml_files_var_obj +pure function get_var_varname (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_varname +end function get_var_varname +!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction +!! @return var_reduction of a diag_yaml_files_var_obj +pure function get_var_reduction (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_reduction +end function get_var_reduction +!> @brief Inquiry for diag_yaml_files_var_obj%var_module +!! @return var_module of a diag_yaml_files_var_obj +pure function get_var_module (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_module +end function get_var_module +!> @brief Inquiry for diag_yaml_files_var_obj%var_skind +!! @return var_skind of a diag_yaml_files_var_obj +pure function get_var_skind (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_skind +end function get_var_skind +!> @brief Inquiry for diag_yaml_files_var_obj%var_outname +!! @return var_outname of a diag_yaml_files_var_obj +pure function get_var_outname (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_outname +end function get_var_outname +!> @brief Inquiry for diag_yaml_files_var_obj%var_longname +!! @return var_longname of a diag_yaml_files_var_obj +pure function get_var_longname (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_longname +end function get_var_longname +!> @brief Inquiry for diag_yaml_files_var_obj%var_units +!! @return var_units of a diag_yaml_files_var_obj +pure function get_var_units (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + res = diag_var_obj%var_units +end function get_var_units +!> @brief Inquiry for diag_yaml_files_var_obj%var_write +!! @return var_write of a diag_yaml_files_var_obj +pure function get_var_write (diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + logical :: res !< What is returned + res = diag_var_obj%var_write +end function get_var_write +!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes +!! @return var_attributes of a diag_yaml_files_var_obj +pure function get_var_attributes(diag_var_obj) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned + res = diag_var_obj%var_attributes +end function get_var_attributes +!> @brief Inquiry for whether var_attributes is allocated +!! @return Flag indicating if var_attributes is allocated +function is_var_attributes(diag_var_obj) & +result(res) + class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried + logical :: res + res = .false. + if (allocated(diag_var_obj%var_attributes)) & + res = .true. +end function is_var_attributes + +!> @brief Initializes the non string values of a diagYamlFiles_type to its +!! default values +subroutine diag_yaml_files_obj_init(obj) + type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize + + obj%file_freq = DIAG_NULL + obj%file_write = .true. + obj%file_duration = DIAG_NULL + obj%file_new_file_freq = DIAG_NULL + obj%file_sub_region%tile = DIAG_NULL +end subroutine diag_yaml_files_obj_init + #endif end module fms_diag_yaml_mod !> @} diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90 deleted file mode 100644 index 7cc6db38f3..0000000000 --- a/diag_manager/fms_diag_yaml_object.F90 +++ /dev/null @@ -1,354 +0,0 @@ -!*********************************************************************** -!* 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 . -!*********************************************************************** -!> @defgroup fms_diag_yaml_object_mod fms_diag_yaml_object_mod -!> @ingroup diag_manager -!! @brief The diag yaml objects are handled here, with variables the correspond to -!! entries in the diag yaml file. The actual parsing of the yaml is handled in -!! @ref fms_diag_yaml_mod. -!! @author Tom Robinson, Uriel Ramirez - -!> @file -!> @brief File for @ref fms_diag_yaml_object_mod - -!> @addtogroup fms_diag_yaml_object_mod -!> @{ -module fms_diag_yaml_object_mod - -use fms_mod , only: fms_c2f_string -use iso_c_binding - implicit none -integer, parameter :: NUM_SUB_REGION_ARRAY = 8 -integer, parameter :: MAX_STR_LEN = 255 - -!> @brief type to hold the sub region information about a file -type subRegion_type - character (len=:), allocatable :: grid_type !< Flag indicating the type of region, - !! acceptable values are "latlon" and "index" - real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region - !! to use if grid_type is set to "latlon" - !! [dim1_begin, dim1_end, dim2_begin, dim2_end, - !! dim3_begin, dim3_end, dim4_begin, dim4_end] - integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to - !! to use if grid_type is set to "index" - !! [dim1_begin, dim1_end, dim2_begin, dim2_end, - !! dim3_begin, dim3_end, dim4_begin, dim4_end] - integer :: tile !< Tile number of the sub region, required if using the "index" grid type - -end type subRegion_type - -type diagYamlFiles_type - character (len=:), allocatable :: file_fname !< file name - character (len=:), allocatable :: file_frequnit !< the frequency unit - integer (c_int) :: file_freq !< the frequency of data - character (len=:), allocatable :: file_timeunit !< The unit of time - character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension - logical :: file_write - character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be - !! created (default is true). - character (len=:), allocatable :: file_realm !< The modeling realm that the variables come from - type(subRegion_type) :: file_sub_region !< type containing info about the subregion, if any - integer :: file_new_file_freq !< Frequency for closing the existing file - character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file. - !! Required if “new_file_freq” used - character (len=:), allocatable :: file_start_time !< Time to start the file for the first time. Requires - !! “new_file_freq” - integer :: file_duration !< How long the file should receive data after start time - !! in “file_duration_units”.  This optional field can only - !! be used if the start_time field is present.  If this field - !! is absent, then the file duration will be equal to the - !! frequency for creating new files. - !! NOTE: The file_duration_units field must also be present if - !! this field is present. - character (len=:), allocatable :: file_duration_units !< The file duration units - !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length - character (len=MAX_STR_LEN), dimension(:), allocatable :: file_varlist !< An array of variable names - !! within a file - character (len=MAX_STR_LEN), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1) - !! and values(dim=2) to be added as global - !! meta data to the file - - contains - procedure :: get_file_fname - procedure :: get_file_frequnit - procedure :: get_file_freq - procedure :: get_file_timeunit - procedure :: get_file_unlimdim - procedure :: get_file_write - procedure :: get_file_realm - procedure :: get_file_sub_region - procedure :: get_file_new_file_freq - procedure :: get_file_new_file_freq_units - procedure :: get_file_start_time - procedure :: get_file_duration - procedure :: get_file_duration_units - procedure :: get_file_varlist - procedure :: get_file_global_meta - procedure :: is_global_meta - -end type diagYamlFiles_type - -type diagYamlFilesVar_type - character (len=:), allocatable :: var_fname !< The field/diagnostic name - character (len=:), allocatable :: var_varname !< The name of the variable - character (len=:), allocatable :: var_reduction !< Reduction to be done on var - character (len=:), allocatable :: var_module !< The module that th variable is in - character (len=:), allocatable :: var_skind !< The type/kind of the variable - character (len=:), allocatable :: string_var_write !< false if the user doesn’t want the variable to be - !! written to the file (default: true). - logical :: var_write !< false if the user doesn’t want the variable to be - !! written to the file (default: true). - character (len=:), allocatable :: var_outname !< Name of the variable as written to the file - character (len=:), allocatable :: var_longname !< Overwrites the long name of the variable - character (len=:), allocatable :: var_units !< Overwrites the units - !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length - character (len=MAX_STR_LEN), dimension (:, :), allocatable :: var_attributes !< Attributes to overwrite or - !! add from diag_yaml - contains - procedure :: get_var_fname - procedure :: get_var_varname - procedure :: get_var_reduction - procedure :: get_var_module - procedure :: get_var_skind - procedure :: get_var_outname - procedure :: get_var_longname - procedure :: get_var_units - procedure :: get_var_write - procedure :: get_var_attributes - procedure :: is_var_attributes -end type diagYamlFilesVar_type - -contains -!!!!!!! YAML FILE INQUIRIES !!!!!!! -!> @brief Inquiry for diag_files_obj%file_fname -!! @return file_fname of a diag_yaml_file obj -pure function get_file_fname (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_files_obj%file_fname -end function get_file_fname -!> @brief Inquiry for diag_files_obj%file_frequnit -!! @return file_frequnit of a diag_yaml_file_obj -pure function get_file_frequnit (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_files_obj%file_frequnit -end function get_file_frequnit -!> @brief Inquiry for diag_files_obj%file_freq -!! @return file_freq of a diag_yaml_file_obj -pure function get_file_freq(diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - integer :: res !< What is returned - res = diag_files_obj%file_freq -end function get_file_freq -!> @brief Inquiry for diag_files_obj%file_timeunit -!! @return file_timeunit of a diag_yaml_file_obj -pure function get_file_timeunit (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_files_obj%file_timeunit -end function get_file_timeunit -!> @brief Inquiry for diag_files_obj%file_unlimdim -!! @return file_unlimdim of a diag_yaml_file_obj -pure function get_file_unlimdim(diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_files_obj%file_unlimdim -end function get_file_unlimdim -!> @brief Inquiry for diag_files_obj%file_write -!! @return file_write of a diag_yaml_file_obj -pure function get_file_write(diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - logical :: res !< What is returned - res = diag_files_obj%file_write -end function get_file_write -!> @brief Inquiry for diag_files_obj%file_realm -!! @return file_realm of a diag_yaml_file_obj -pure function get_file_realm(diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (:), allocatable :: res !< What is returned - res = diag_files_obj%file_realm -end function get_file_realm -!> @brief Inquiry for diag_files_obj%file_subregion -!! @return file_sub_region of a diag_yaml_file_obj -pure function get_file_sub_region (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - type(subRegion_type) :: res !< What is returned - res = diag_files_obj%file_sub_region -end function get_file_sub_region -!> @brief Inquiry for diag_files_obj%file_new_file_freq -!! @return file_new_file_freq of a diag_yaml_file_obj -pure function get_file_new_file_freq(diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - integer :: res !< What is returned - res = diag_files_obj%file_new_file_freq -end function get_file_new_file_freq -!> @brief Inquiry for diag_files_obj%file_new_file_freq_units -!! @return file_new_file_freq_units of a diag_yaml_file_obj -pure function get_file_new_file_freq_units (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (:), allocatable :: res !< What is returned - res = diag_files_obj%file_new_file_freq_units -end function get_file_new_file_freq_units -!> @brief Inquiry for diag_files_obj%file_start_time -!! @return file_start_time of a diag_yaml_file_obj -pure function get_file_start_time (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_files_obj%file_start_time -end function get_file_start_time -!> @brief Inquiry for diag_files_obj%file_duration -!! @return file_duration of a diag_yaml_file_obj -pure function get_file_duration (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - integer :: res !< What is returned - res = diag_files_obj%file_duration -end function get_file_duration -!> @brief Inquiry for diag_files_obj%file_duration_units -!! @return file_duration_units of a diag_yaml_file_obj -pure function get_file_duration_units (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (:), allocatable :: res !< What is returned - res = diag_files_obj%file_duration_units -end function get_file_duration_units -!> @brief Inquiry for diag_files_obj%file_varlist -!! @return file_varlist of a diag_yaml_file_obj -pure function get_file_varlist (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (:), allocatable :: res(:) !< What is returned - res = diag_files_obj%file_varlist -end function get_file_varlist -!> @brief Inquiry for diag_files_obj%file_global_meta -!! @return file_global_meta of a diag_yaml_file_obj -pure function get_file_global_meta (diag_files_obj) result (res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - character (:), allocatable :: res(:,:) !< What is returned - res = diag_files_obj%file_global_meta -end function get_file_global_meta -!> @brief Inquiry for whether file_global_meta is allocated -!! @return Flag indicating if file_global_meta is allocated -function is_global_meta(diag_files_obj) result(res) - class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried - logical :: res - res = .false. - if (allocated(diag_files_obj%file_global_meta)) & - res = .true. -end function -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!! YAML VAR INQUIRIES !!!!!!! -!> @brief Inquiry for diag_yaml_files_var_obj%var_fname -!! @return var_fname of a diag_yaml_files_var_obj -pure function get_var_fname (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_fname -end function get_var_fname -!> @brief Inquiry for diag_yaml_files_var_obj%var_varname -!! @return var_varname of a diag_yaml_files_var_obj -pure function get_var_varname (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_varname -end function get_var_varname -!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction -!! @return var_reduction of a diag_yaml_files_var_obj -pure function get_var_reduction (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_reduction -end function get_var_reduction -!> @brief Inquiry for diag_yaml_files_var_obj%var_module -!! @return var_module of a diag_yaml_files_var_obj -pure function get_var_module (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_module -end function get_var_module -!> @brief Inquiry for diag_yaml_files_var_obj%var_skind -!! @return var_skind of a diag_yaml_files_var_obj -pure function get_var_skind (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_skind -end function get_var_skind -!> @brief Inquiry for diag_yaml_files_var_obj%var_outname -!! @return var_outname of a diag_yaml_files_var_obj -pure function get_var_outname (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_outname -end function get_var_outname -!> @brief Inquiry for diag_yaml_files_var_obj%var_longname -!! @return var_longname of a diag_yaml_files_var_obj -pure function get_var_longname (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_longname -end function get_var_longname -!> @brief Inquiry for diag_yaml_files_var_obj%var_units -!! @return var_units of a diag_yaml_files_var_obj -pure function get_var_units (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=:), allocatable :: res !< What is returned - res = diag_var_obj%var_units -end function get_var_units -!> @brief Inquiry for diag_yaml_files_var_obj%var_write -!! @return var_write of a diag_yaml_files_var_obj -pure function get_var_write (diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - logical :: res !< What is returned - res = diag_var_obj%var_write -end function get_var_write -!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes -!! @return var_attributes of a diag_yaml_files_var_obj -pure function get_var_attributes(diag_var_obj) result (res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned - res = diag_var_obj%var_attributes -end function get_var_attributes -!> @brief Inquiry for whether var_attributes is allocated -!! @return Flag indicating if var_attributes is allocated -function is_var_attributes(diag_var_obj) result(res) - class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried - logical :: res - res = .false. - if (allocated(diag_var_obj%var_attributes)) & - res = .true. -end function is_var_attributes - -!> @brief Initializes the non string values of a diagYamlFiles_type to its -!! default values -subroutine diag_yaml_files_obj_init(obj) - type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize - - obj%file_freq = 0 - obj%file_write = .true. - obj%file_duration = 0 - obj%file_new_file_freq = 0 - obj%file_sub_region%tile = 0 -end subroutine diag_yaml_files_obj_init - -end module fms_diag_yaml_object_mod -!> @} -! close documentation grouping - diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90 index d939de7b91..95f93513e6 100644 --- a/test_fms/diag_manager/test_diag_yaml.F90 +++ b/test_fms/diag_manager/test_diag_yaml.F90 @@ -24,7 +24,7 @@ program test_diag_yaml #ifdef use_yaml use FMS_mod, only: fms_init, fms_end use fms_diag_yaml_mod -use fms_diag_yaml_object_mod +use diag_data_mod, only: DIAG_NULL use mpp_mod use platform_mod @@ -174,16 +174,16 @@ subroutine compare_diag_files(res) call compare_result("file_write 3", res(3)%get_file_write(), .true.) call compare_result("file_new_file_freq 1", res(1)%get_file_new_file_freq(), 6) - call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), 0) - call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), 0) + call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), DIAG_NULL) + call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), DIAG_NULL) call compare_result("file_new_file_freq_units 1", res(1)%get_file_new_file_freq_units(), "hours") call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), "") call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), "") call compare_result("file_duration 1", res(1)%get_file_duration(), 12) - call compare_result("file_duration 2", res(2)%get_file_duration(), 0) - call compare_result("file_duration 3", res(3)%get_file_duration(), 0) + call compare_result("file_duration 2", res(2)%get_file_duration(), DIAG_NULL) + call compare_result("file_duration 3", res(3)%get_file_duration(), DIAG_NULL) call compare_result("file_duration_units 1", res(1)%get_file_duration_units(), "hours") call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), "") From 0768cfcbf36de242337468f746803b3752f16d44 Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Thu, 17 Feb 2022 14:40:31 -0500 Subject: [PATCH 023/142] Dm update (#913) * Changing script test_diag_manager2.sh to enable testing of linked list class. --- test_fms/diag_manager/test_diag_manager2.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 294e1d50ed..6309cf52f9 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -119,4 +119,4 @@ echo "Test linked list " rm -f input.nml diag_table touch input.nml cp $top_srcdir/test_fms/diag_manager/diagTables/diag_table_25 diag_table -run_test test_diag_dlinked_list 1 skip +run_test test_diag_dlinked_list 1 From 8354493193b3a2b2dbcb15648cb11de894664547 Mon Sep 17 00:00:00 2001 From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com> Date: Fri, 25 Feb 2022 07:49:18 -0500 Subject: [PATCH 024/142] Removes intel18 testing due to a compiler issue (#915) --- .github/workflows/parallelWorks_intel_pr.yml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/.github/workflows/parallelWorks_intel_pr.yml b/.github/workflows/parallelWorks_intel_pr.yml index fb08a3fa7f..5c841d5681 100644 --- a/.github/workflows/parallelWorks_intel_pr.yml +++ b/.github/workflows/parallelWorks_intel_pr.yml @@ -1,4 +1,4 @@ -name: Pull Request CI libFMS with intel18 and intel21 +name: Pull Request CI libFMS with intel21 on: [pull_request,workflow_dispatch] jobs: @@ -9,10 +9,7 @@ jobs: max-parallel: 2 matrix: include: -# Turn this back on when fixed - - runname: FMS with intel 18 - runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/PRFMSintel18StartClusters.py $GITHUB_REF -# Runs on FMS_CONTAINER_CI cluster +# Runs on FMS_CONTAINER_CI cluster with intel 2021 - runname: FMS with intel 2021 container runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/PRFMSintel21StartClusters.py $GITHUB_REF steps: @@ -29,7 +26,7 @@ jobs: matrix: include: - cluster: FMS_CONTAINER_CI - - cluster: fms_intel18_ci + # - cluster: fms_intel18_ci steps: - name: Turn off cluster env: From 8165679fc0b61cde7cf3a19520ac846b7af3ad6e Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 25 Feb 2022 08:30:26 -0500 Subject: [PATCH 025/142] diag_yaml update (#901) * Fix issue checking if frequency is valid, fix reading the diurnal and pow reduction * Corrects error message * changes logic to make more sense --- diag_manager/fms_diag_yaml.F90 | 8 ++++---- test_fms/diag_manager/diagTables/diag_table_yaml_26 | 2 +- test_fms/diag_manager/test_diag_yaml.F90 | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 22d344ec39..67f0feebdd 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -484,8 +484,8 @@ function get_total_num_vars(diag_yaml_id, diag_file_ids) & subroutine check_file_freq(fileobj) type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check - if (fileobj%file_freq < 1 ) & - call mpp_error(FATAL, "freq must be greater than 0. & + if (.not. (fileobj%file_freq >= -1) ) & + call mpp_error(FATAL, "freq must be greater than or equal to -1. & &Check you entry for"//trim(fileobj%file_fname)) if(.not. is_valid_time_units(fileobj%file_frequnit)) & call mpp_error(FATAL, trim(fileobj%file_frequnit)//" is not a valid file_frequnit. & @@ -574,14 +574,14 @@ subroutine check_field_reduction(field) n_diurnal = 0 pow_value = 0 ioerror = 0 - if (field%var_reduction(1:7) .eq. "diurnal") then + if (index(field%var_reduction, "diurnal") .ne. 0) then READ (UNIT=field%var_reduction(8:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) n_diurnal if (ioerror .ne. 0) & call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(field%var_reduction)) if (n_diurnal .le. 0) & call mpp_error(FATAL, "Diurnal samples should be greater than 0. & & Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname)) - elseif (field%var_reduction(1:3) .eq. "pow") then + elseif (index(field%var_reduction, "pow") .ne. 0) then READ (UNIT=field%var_reduction(4:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) pow_value if (ioerror .ne. 0) & call mpp_error(FATAL, "Error getting the power value from "//trim(field%var_reduction)) diff --git a/test_fms/diag_manager/diagTables/diag_table_yaml_26 b/test_fms/diag_manager/diagTables/diag_table_yaml_26 index d82038bd6a..d7c6132ded 100644 --- a/test_fms/diag_manager/diagTables/diag_table_yaml_26 +++ b/test_fms/diag_manager/diagTables/diag_table_yaml_26 @@ -41,7 +41,7 @@ diag_files: dim1_begin: 64.0 dim3_end: 20.0 - file_name: normal2 - freq: 24 + freq: -1 freq_units: days time_units: hours unlimdim: records diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90 index 95f93513e6..32ef98cd9d 100644 --- a/test_fms/diag_manager/test_diag_yaml.F90 +++ b/test_fms/diag_manager/test_diag_yaml.F90 @@ -151,7 +151,7 @@ subroutine compare_diag_files(res) call compare_result("file_freq 1", res(1)%get_file_freq(), 6) call compare_result("file_freq 2", res(2)%get_file_freq(), 24) - call compare_result("file_freq 3", res(3)%get_file_freq(), 24) + call compare_result("file_freq 3", res(3)%get_file_freq(), -1) call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), "hours") call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), "days") From d6324ff57692d8ece80a597a029a0bbf4cdd156b Mon Sep 17 00:00:00 2001 From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com> Date: Fri, 25 Feb 2022 08:32:57 -0500 Subject: [PATCH 026/142] Dm obj alloc (#910) * Changes fms_diag_object to fmsDiagObject_type * Removes the multi-dimensional type extentions that will no be used * Uses a class(*) variable for missing_value and data_RANGE Fills in CMOR_MISSING_VALUE for missing_value if none is given Adds rountines for fmsDiagObject_type * Puts result for get_* functions on its own line in diag_object * Adds brief doxygen to get_* functions in diag_object * Changes allocated_ to has_ in fmsDiagObject functions * Updates comments on get functions in diag object Makes all integer get functions return diag_null if the variable is not allocated * Sets up parmeter diag_null_string as a single empty space * Adds is_ functions for logical variables in diag object * Adds has_ funcions to fms_diag_yaml.F90 * Comments out has_ functions for variables that are derived types in the diag_object * Fixes class variable to be intent(in) in a has function in diag yaml * Fixes has function for new_file_freq * Changes type to class in a has function * Fixes has function for variable on the stack --- diag_manager/fms_diag_object.F90 | 227 +++++++++++++++++++++++++++-- diag_manager/fms_diag_yaml.F90 | 235 +++++++++++++++++++++++++++++++ 2 files changed, 449 insertions(+), 13 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 76a46834c6..417d896cfe 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -34,7 +34,7 @@ module fms_diag_object_mod type fmsDiagObject_type #ifdef use_yaml type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table - type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table + type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table #endif integer, allocatable, private :: diag_id !< unique id for varable class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the @@ -67,17 +67,13 @@ module fms_diag_object_mod class(*), allocatable, private :: missing_value !< The missing fill value class(*), allocatable, private :: data_RANGE !< The range of the variable data type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object -!> \brief Extends the variable object to work with multiple types of data - class(*), allocatable :: vardata0 - class(*), allocatable, dimension(:) :: vardata1 - class(*), allocatable, dimension(:,:) :: vardata2 - class(*), allocatable, dimension(:,:,:) :: vardata3 - class(*), allocatable, dimension(:,:,:,:) :: vardata4 - class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 - - - - contains + 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 @@ -93,6 +89,36 @@ module fms_diag_object_mod 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 +!TODO procedure :: has_diag_file + procedure :: has_diag_id + procedure :: has_fileob + procedure :: has_metadata + 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_err_msg + procedure :: has_interp_method + procedure :: has_frequency + procedure :: has_output_units + procedure :: has_t + procedure :: has_tile_count + procedure :: has_axis_ids + procedure :: has_area + procedure :: has_volume + procedure :: has_missing_value + procedure :: has_data_RANGE + procedure :: has_axis ! Get functions procedure :: get_diag_id => fms_diag_get_id procedure :: get_metadata @@ -745,6 +771,181 @@ end function get_data_RANGE ! 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_file is allocated +!!! @return true if obj%diag_file is allocated +!logical function has_diag_file (obj) +! class (fmsDiagObject_type), intent(in) :: obj !< diag object +! has_diag_file = allocated(obj%diag_file) +!end function has_diag_file +!> @brief Checks if obj%diag_id is allocated +!! @return true if obj%diag_id is allocated +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%fileob pointer is associated +!! @return true if obj%fileob is associated +logical function has_fileob (obj) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + has_fileob = associated(obj%fileob) +end function has_fileob +!> @brief Checks if obj%metadata is allocated +!! @return true if obj%metadata is allocated +logical function has_metadata (obj) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + has_metadata = allocated(obj%metadata) +end function has_metadata +!> @brief Checks if obj%static is allocated +!! @return true if obj%static is allocated +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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%err_msg is allocated +!! @return true if obj%err_msg is allocated +logical function has_err_msg (obj) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + has_err_msg = allocated(obj%err_msg) +end function has_err_msg +!> @brief Checks if obj%interp_method is allocated +!! @return true if obj%interp_method is allocated +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 +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 +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 +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 +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%axis_ids is allocated +!! @return true if obj%axis_ids is allocated +logical function has_axis_ids (obj) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + has_axis_ids = allocated(obj%axis_ids) +end function has_axis_ids +!> @brief Checks if obj%area is allocated +!! @return true if obj%area is allocated +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 +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 +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 +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 Checks if obj%axis is allocated +!! @return true if obj%axis is allocated +logical function has_axis (obj) + class (fmsDiagObject_type), intent(in) :: obj !< diag object + has_axis = allocated(obj%axis) +end function has_axis end module fms_diag_object_mod diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 67f0feebdd..e684759630 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -115,6 +115,24 @@ module fms_diag_yaml_mod procedure :: get_file_varlist procedure :: get_file_global_meta procedure :: is_global_meta + !> Has functions to determine if allocatable variables are true. If a variable is not an allocatable + !! then is will always return .true. + procedure :: has_file_fname + procedure :: has_file_frequnit + procedure :: has_file_freq + procedure :: has_file_timeunit + procedure :: has_file_unlimdim + procedure :: has_file_write + procedure :: has_string_file_write + procedure :: has_file_realm + procedure :: has_file_sub_region + procedure :: has_file_new_file_freq + procedure :: has_file_new_file_freq_units + procedure :: has_file_start_time + procedure :: has_file_duration + procedure :: has_file_duration_units + procedure :: has_file_varlist + procedure :: has_file_global_meta end type diagYamlFiles_type @@ -150,6 +168,19 @@ module fms_diag_yaml_mod procedure :: get_var_write procedure :: get_var_attributes procedure :: is_var_attributes + + procedure :: has_var_fname + procedure :: has_var_varname + procedure :: has_var_reduction + procedure :: has_var_module + procedure :: has_var_skind + procedure :: has_string_var_write + procedure :: has_var_write + procedure :: has_var_outname + procedure :: has_var_longname + procedure :: has_var_units + procedure :: has_var_attributes + end type diagYamlFilesVar_type !> @brief Object that holds the information of the diag_yaml @@ -164,6 +195,12 @@ module fms_diag_yaml_mod procedure :: get_basedate !< Returns the basedate array procedure :: get_diag_files !< Returns the diag_files array procedure :: get_diag_fields !< Returns the diag_field array + + procedure :: has_diag_title + procedure :: has_diag_basedate + procedure :: has_diag_files + procedure :: has_diag_fields + end type diagYamlObject_type type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml @@ -855,6 +892,204 @@ subroutine diag_yaml_files_obj_init(obj) obj%file_sub_region%tile = DIAG_NULL end subroutine diag_yaml_files_obj_init +!> @brief Checks if obj%file_fname is allocated +!! @return true if obj%file_fname is allocated +pure logical function has_file_fname (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_fname = allocated(obj%file_fname) +end function has_file_fname +!> @brief Checks if obj%file_frequnit is allocated +!! @return true if obj%file_frequnit is allocated +pure logical function has_file_frequnit (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_frequnit = allocated(obj%file_frequnit) +end function has_file_frequnit +!> @brief obj%file_freq is on the stack, so the object always has it +!! @return true if obj%file_freq is allocated +pure logical function has_file_freq (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_freq = .true. +end function has_file_freq +!> @brief Checks if obj%file_timeunit is allocated +!! @return true if obj%file_timeunit is allocated +pure logical function has_file_timeunit (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_timeunit = allocated(obj%file_timeunit) +end function has_file_timeunit +!> @brief Checks if obj%file_unlimdim is allocated +!! @return true if obj%file_unlimdim is allocated +pure logical function has_file_unlimdim (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_unlimdim = allocated(obj%file_unlimdim) +end function has_file_unlimdim +!> @brief Checks if obj%file_write is on the stack, so this will always be true +!! @return true +pure logical function has_file_write (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_write = .true. +end function has_file_write +!> @brief Checks if obj%string_file_write is allocated +!! @return true if obj%string_file_write is allocated +pure logical function has_string_file_write (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_string_file_write = allocated(obj%string_file_write) +end function has_string_file_write +!> @brief Checks if obj%file_realm is allocated +!! @return true if obj%file_realm is allocated +pure logical function has_file_realm (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_realm = allocated(obj%file_realm) +end function has_file_realm +!> @brief Checks if obj%file_sub_region is being used and has the sub region variables allocated +!! @return true if obj%file_sub_region sub region variables are allocated +pure logical function has_file_sub_region (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + if ( (allocated(obj%file_sub_region%grid_type) .and. allocated(obj%file_sub_region%lat_lon_sub_region)) & + .or.(allocated(obj%file_sub_region%grid_type) .and. allocated(obj%file_sub_region%index_sub_region))) & + then + has_file_sub_region = .true. + else + has_file_sub_region = .false. + endif +end function has_file_sub_region +!> @brief obj%file_new_file_freq is defined on the stack, so this will return true +!! @return true +pure logical function has_file_new_file_freq (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_new_file_freq = .true. +end function has_file_new_file_freq +!> @brief Checks if obj%file_new_file_freq_units is allocated +!! @return true if obj%file_new_file_freq_units is allocated +pure logical function has_file_new_file_freq_units (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_new_file_freq_units = allocated(obj%file_new_file_freq_units) +end function has_file_new_file_freq_units +!> @brief Checks if obj%file_start_time is allocated +!! @return true if obj%file_start_time is allocated +pure logical function has_file_start_time (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_start_time = allocated(obj%file_start_time) +end function has_file_start_time +!> @brief obj%file_duration is allocated on th stack, so this is always true +!! @return true +pure logical function has_file_duration (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_duration = .true. +end function has_file_duration +!> @brief obj%file_duration_units is on the stack, so this will retrun true +!! @return true +pure logical function has_file_duration_units (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_duration_units = .true. +end function has_file_duration_units +!> @brief Checks if obj%file_varlist is allocated +!! @return true if obj%file_varlist is allocated +pure logical function has_file_varlist (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_varlist = allocated(obj%file_varlist) +end function has_file_varlist +!> @brief Checks if obj%file_global_meta is allocated +!! @return true if obj%file_global_meta is allocated +pure logical function has_file_global_meta (obj) + class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize + has_file_global_meta = allocated(obj%file_global_meta) +end function has_file_global_meta + +!> @brief Checks if obj%var_fname is allocated +!! @return true if obj%var_fname is allocated +pure logical function has_var_fname (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_fname = allocated(obj%var_fname) +end function has_var_fname +!> @brief Checks if obj%var_varname is allocated +!! @return true if obj%var_varname is allocated +pure logical function has_var_varname (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_varname = allocated(obj%var_varname) +end function has_var_varname +!> @brief Checks if obj%var_reduction is allocated +!! @return true if obj%var_reduction is allocated +pure logical function has_var_reduction (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_reduction = allocated(obj%var_reduction) +end function has_var_reduction +!> @brief Checks if obj%var_module is allocated +!! @return true if obj%var_module is allocated +pure logical function has_var_module (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_module = allocated(obj%var_module) +end function has_var_module +!> @brief Checks if obj%var_skind is allocated +!! @return true if obj%var_skind is allocated +pure logical function has_var_skind (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_skind = allocated(obj%var_skind) +end function has_var_skind +!> @brief Checks if obj%string_var_write is allocated +!! @return true if obj%string_var_write is allocated +pure logical function has_string_var_write (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_string_var_write = allocated(obj%string_var_write) +end function has_string_var_write +!> @brief obj%var_write is on the stack, so this returns true +!! @return true +pure logical function has_var_write (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_write = .true. +end function has_var_write +!> @brief Checks if obj%var_outname is allocated +!! @return true if obj%var_outname is allocated +pure logical function has_var_outname (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_outname = allocated(obj%var_outname) +end function has_var_outname +!> @brief Checks if obj%var_longname is allocated +!! @return true if obj%var_longname is allocated +pure logical function has_var_longname (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_longname = allocated(obj%var_longname) +end function has_var_longname +!> @brief Checks if obj%var_units is allocated +!! @return true if obj%var_units is allocated +pure logical function has_var_units (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_units = allocated(obj%var_units) +end function has_var_units +!> @brief Checks if obj%var_attributes is allocated +!! @return true if obj%var_attributes is allocated +pure logical function has_var_attributes (obj) + class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize + has_var_attributes = allocated(obj%var_attributes) +end function has_var_attributes + + + +!> @brief Checks if obj%diag_title is allocated +!! @return true if obj%diag_title is allocated +pure logical function has_diag_title (obj) + class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize + has_diag_title = allocated(obj%diag_title) +end function has_diag_title +!> @brief obj%diag_basedate is on the stack, so this is always true +!! @return true +pure logical function has_diag_basedate (obj) + class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize + has_diag_basedate = .true. +end function has_diag_basedate +!> @brief Checks if obj%diag_files is allocated +!! @return true if obj%diag_files is allocated +pure logical function has_diag_files (obj) + class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize + has_diag_files = allocated(obj%diag_files) +end function has_diag_files +!> @brief Checks if obj%diag_fields is allocated +!! @return true if obj%diag_fields is allocated +pure logical function has_diag_fields (obj) + class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize + has_diag_fields = allocated(obj%diag_fields) +end function has_diag_fields + + #endif end module fms_diag_yaml_mod !> @} From b4346f878b658fda32467fc0d2dd40f49a4a8cac Mon Sep 17 00:00:00 2001 From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com> Date: Fri, 25 Feb 2022 14:34:52 -0500 Subject: [PATCH 027/142] Dm pure (#923) * Updates functions to be pure in fms_diag_object and fms_diag_yaml --- diag_manager/fms_diag_object.F90 | 94 ++++++++++++++++---------------- diag_manager/fms_diag_yaml.F90 | 2 +- 2 files changed, 48 insertions(+), 48 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 417d896cfe..d4085719dd 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -459,7 +459,7 @@ end function diag_obj_is_static !> @brief Gets metedata !! @return copy of metadata string array, or a single space if metadata is not allocated -function get_metadata (obj) & +pure function get_metadata (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable, dimension(:) :: rslt @@ -473,7 +473,7 @@ function get_metadata (obj) & end function get_metadata !> @brief Gets static !! @return copy of variable static -function get_static (obj) & +pure function get_static (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object logical :: rslt @@ -481,7 +481,7 @@ function get_static (obj) & end function get_static !> @brief Gets regisetered !! @return copy of registered -function get_registered (obj) & +pure function get_registered (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object logical :: rslt @@ -489,7 +489,7 @@ function get_registered (obj) & end function get_registered !> @brief Gets mask variant !! @return copy of mask variant -function get_mask_variant (obj) & +pure function get_mask_variant (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object logical :: rslt @@ -497,7 +497,7 @@ function get_mask_variant (obj) & end function get_mask_variant !> @brief Gets local !! @return copy of local -function get_local (obj) & +pure function get_local (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object logical :: rslt @@ -514,7 +514,7 @@ end function get_local !end function get_init_time !> @brief Gets vartype !! @return copy of The integer related to the variable type -function get_vartype (obj) & +pure function get_vartype (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer :: rslt @@ -522,7 +522,7 @@ function get_vartype (obj) & end function get_vartype !> @brief Gets varname !! @return copy of the variable name -function get_varname (obj) & +pure function get_varname (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -530,7 +530,7 @@ function get_varname (obj) & end function get_varname !> @brief Gets longname !! @return copy of the variable long name or a single string if there is no long name -function get_longname (obj) & +pure function get_longname (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -542,7 +542,7 @@ function get_longname (obj) & end function get_longname !> @brief Gets standname !! @return copy of the standard name or an empty string if standname is not allocated -function get_standname (obj) & +pure function get_standname (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -554,7 +554,7 @@ function get_standname (obj) & end function get_standname !> @brief Gets units !! @return copy of the units or an empty string if not allocated -function get_units (obj) & +pure function get_units (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -566,7 +566,7 @@ function get_units (obj) & 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 -function get_modname (obj) & +pure function get_modname (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -578,7 +578,7 @@ function get_modname (obj) & end function get_modname !> @brief Gets realm !! @return copy of the variables modeling realm or an empty string if not allocated -function get_realm (obj) & +pure function get_realm (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -590,7 +590,7 @@ function get_realm (obj) & end function get_realm !> @brief Gets err_msg !! @return copy of The error message stored in err_msg or an empty string if not allocated -function get_err_msg (obj) & +pure function get_err_msg (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -602,7 +602,7 @@ function get_err_msg (obj) & end function get_err_msg !> @brief Gets interp_method !! @return copy of The interpolation method or an empty string if not allocated -function get_interp_method (obj) & +pure function get_interp_method (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object character(len=:), allocatable :: rslt @@ -614,7 +614,7 @@ function get_interp_method (obj) & end function get_interp_method !> @brief Gets frequency !! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated -function get_frequency (obj) & +pure function get_frequency (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer, allocatable, dimension (:) :: rslt @@ -628,7 +628,7 @@ function get_frequency (obj) & 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 -function get_output_units (obj) & +pure function get_output_units (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer,allocatable, dimension (:) :: rslt @@ -642,7 +642,7 @@ function get_output_units (obj) & end function get_output_units !> @brief Gets t !! @return copy of t -function get_t (obj) & +pure function get_t (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer :: rslt @@ -654,7 +654,7 @@ function get_t (obj) & end function get_t !> @brief Gets tile_count !! @return copy of the number of tiles or diag_null if tile_count is not allocated -function get_tile_count (obj) & +pure function get_tile_count (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer :: rslt @@ -666,7 +666,7 @@ function get_tile_count (obj) & end function get_tile_count !> @brief Gets axis_ids !! @return copy of The axis IDs array or a diag_null if no axis IDs are set -function get_axis_ids (obj) & +pure function get_axis_ids (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer, allocatable, dimension(:) :: rslt @@ -680,7 +680,7 @@ function get_axis_ids (obj) & end function get_axis_ids !> @brief Gets area !! @return copy of the area or diag_null if not allocated -function get_area (obj) & +pure function get_area (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer :: rslt @@ -692,7 +692,7 @@ function get_area (obj) & end function get_area !> @brief Gets volume !! @return copy of the volume or diag_null if volume is not allocated -function get_volume (obj) & +pure function get_volume (obj) & result(rslt) class (fmsDiagObject_type), intent(in) :: obj !< diag object integer :: rslt @@ -787,43 +787,43 @@ end function get_data_RANGE !end function has_diag_file !> @brief Checks if obj%diag_id is allocated !! @return true if obj%diag_id is allocated -logical function has_diag_id (obj) +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%fileob pointer is associated !! @return true if obj%fileob is associated -logical function has_fileob (obj) +pure logical function has_fileob (obj) class (fmsDiagObject_type), intent(in) :: obj !< diag object has_fileob = associated(obj%fileob) end function has_fileob !> @brief Checks if obj%metadata is allocated !! @return true if obj%metadata is allocated -logical function has_metadata (obj) +pure logical function has_metadata (obj) class (fmsDiagObject_type), intent(in) :: obj !< diag object has_metadata = allocated(obj%metadata) end function has_metadata !> @brief Checks if obj%static is allocated !! @return true if obj%static is allocated -logical function has_static (obj) +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 -logical function has_registered (obj) +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 -logical function has_mask_variant (obj) +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 -logical function has_local (obj) +pure logical function has_local (obj) class (fmsDiagObject_type), intent(in) :: obj !< diag object has_local = allocated(obj%local) end function has_local @@ -835,115 +835,115 @@ end function has_local !end function has_init_time !> @brief Checks if obj%vartype is allocated !! @return true if obj%vartype is allocated -logical function has_vartype (obj) +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 -logical function has_varname (obj) +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 -logical function has_longname (obj) +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 -logical function has_standname (obj) +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 -logical function has_units (obj) +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 -logical function has_modname (obj) +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 -logical function has_realm (obj) +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%err_msg is allocated !! @return true if obj%err_msg is allocated -logical function has_err_msg (obj) +pure logical function has_err_msg (obj) class (fmsDiagObject_type), intent(in) :: obj !< diag object has_err_msg = allocated(obj%err_msg) end function has_err_msg !> @brief Checks if obj%interp_method is allocated !! @return true if obj%interp_method is allocated -logical function has_interp_method (obj) +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 -logical function has_frequency (obj) +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 -logical function has_output_units (obj) +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 -logical function has_t (obj) +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 -logical function has_tile_count (obj) +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%axis_ids is allocated !! @return true if obj%axis_ids is allocated -logical function has_axis_ids (obj) +pure logical function has_axis_ids (obj) class (fmsDiagObject_type), intent(in) :: obj !< diag object has_axis_ids = allocated(obj%axis_ids) end function has_axis_ids !> @brief Checks if obj%area is allocated !! @return true if obj%area is allocated -logical function has_area (obj) +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 -logical function has_volume (obj) +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 -logical function has_missing_value (obj) +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 -logical function has_data_RANGE (obj) +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 Checks if obj%axis is allocated !! @return true if obj%axis is allocated -logical function has_axis (obj) +pure logical function has_axis (obj) class (fmsDiagObject_type), intent(in) :: obj !< diag object has_axis = allocated(obj%axis) end function has_axis diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index e684759630..9c3ae48483 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -211,7 +211,7 @@ module fms_diag_yaml_mod !> @brief gets the diag_yaml module variable !! @return a copy of the diag_yaml module variable -function get_diag_yaml_obj() & +pure function get_diag_yaml_obj() & result(res) type (diagYamlObject_type) :: res From 7658ead057c9ac4aa5dcc2ece17d0d299dd11ce9 Mon Sep 17 00:00:00 2001 From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com> Date: Tue, 1 Mar 2022 09:01:55 -0500 Subject: [PATCH 028/142] Dm p rupdate (#924) Pulls in #907 and #911 to dmUpdate branch Co-authored-by: Uriel Ramirez --- CMakeLists.txt | 2 + Makefile.am | 1 + configure.ac | 2 + docs/grouping.h | 4 + libFMS/Makefile.am | 1 + parser/yaml_parser.F90 | 8 + string_utils/Makefile.am | 40 +++++ string_utils/fms_string_utils.F90 | 148 ++++++++++++++++++ string_utils/fms_string_utils_binding.c | 164 ++++++++++++++++++++ test_fms/Makefile.am | 2 +- test_fms/parser/test_yaml_parser.F90 | 10 ++ test_fms/parser/test_yaml_parser.sh | 2 + test_fms/string_utils/Makefile.am | 44 ++++++ test_fms/string_utils/test_string_utils.F90 | 158 +++++++++++++++++++ test_fms/string_utils/test_string_utils.sh | 29 ++++ 15 files changed, 614 insertions(+), 1 deletion(-) create mode 100644 string_utils/Makefile.am create mode 100644 string_utils/fms_string_utils.F90 create mode 100644 string_utils/fms_string_utils_binding.c create mode 100644 test_fms/string_utils/Makefile.am create mode 100644 test_fms/string_utils/test_string_utils.F90 create mode 100755 test_fms/string_utils/test_string_utils.sh diff --git a/CMakeLists.txt b/CMakeLists.txt index fa4b9e3a73..c55789e3ff 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -165,6 +165,7 @@ list(APPEND fms_fortran_src_files random_numbers/random_numbers.F90 sat_vapor_pres/sat_vapor_pres_k.F90 sat_vapor_pres/sat_vapor_pres.F90 + string_utils/fms_string_utils.F90 time_interp/time_interp_external.F90 time_interp/time_interp_external2.F90 time_interp/time_interp.F90 @@ -188,6 +189,7 @@ list(APPEND fms_c_src_files mosaic/read_mosaic.c mpp/mpp_memuse.c parser/yaml_parser_binding.c + string_utils/fms_string_utils_binding.c ) # Collect FMS header files diff --git a/Makefile.am b/Makefile.am index 9254d916e5..b12e9d1ff7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -43,6 +43,7 @@ SUBDIRS = \ mosaic2 \ fms \ parser \ + string_utils \ affinity \ mosaic \ time_manager \ diff --git a/configure.ac b/configure.ac index cc1367ccb8..48b922a011 100644 --- a/configure.ac +++ b/configure.ac @@ -357,6 +357,7 @@ AC_CONFIG_FILES([ libFMS/Makefile docs/Makefile parser/Makefile + string_utils/Makefile test_fms/test_common.sh test_fms/Makefile test_fms/diag_manager/Makefile @@ -378,6 +379,7 @@ AC_CONFIG_FILES([ test_fms/affinity/Makefile test_fms/coupler/Makefile test_fms/parser/Makefile + test_fms/string_utils/Makefile FMS.pc ]) diff --git a/docs/grouping.h b/docs/grouping.h index 2e2f7a82de..2ab27141ca 100644 --- a/docs/grouping.h +++ b/docs/grouping.h @@ -130,6 +130,10 @@ * */ +/** @defgroup string_utils String Utils + * + */ + /** @defgroup time_interp Time Interpolator * */ diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index e27fa3d7c1..8111b632f4 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -63,6 +63,7 @@ libFMS_la_LIBADD += $(top_builddir)/random_numbers/librandom_numbers.la libFMS_la_LIBADD += $(top_builddir)/diag_integral/libdiag_integral.la libFMS_la_LIBADD += $(top_builddir)/sat_vapor_pres/libsat_vapor_pres.la libFMS_la_LIBADD += $(top_builddir)/parser/libparser.la +libFMS_la_LIBADD += $(top_builddir)/string_utils/libstring_utils.la libFMS_la_LIBADD += $(top_builddir)/libFMS_mod.la # At least one source file must be included to please Automake. diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index 720e50c6a3..e386e6060e 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -283,6 +283,14 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to r8") type is (character(len=*)) call string_copy(key_value, buffer) + type is (logical) + if (lowercase(trim(buffer)) == "false") then + key_value = .false. + elseif (lowercase(trim(buffer)) == "true") then + key_value = .true. + else + call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to logical") + endif class default call mpp_error(FATAL, "The type of your buffer in your get_value_from_key call for key "//trim(key_name)//& &" is not supported. Only i4, i8, r4, r8 and strings are supported.") diff --git a/string_utils/Makefile.am b/string_utils/Makefile.am new file mode 100644 index 0000000000..ca0c3ab5ef --- /dev/null +++ b/string_utils/Makefile.am @@ -0,0 +1,40 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the constants directory of the FMS +# package. + +# Include .h and .mod files. +AM_CPPFLAGS = -I$(top_srcdir)/include +AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) + +# Build this uninstalled convenience library. +noinst_LTLIBRARIES = libstring_utils.la + +# The convenience library depends on its source. +libstring_utils_la_SOURCES = \ + fms_string_utils.F90 \ + fms_string_utils_binding.c + +MODFILES = \ + fms_string_utils_mod.$(FC_MODEXT) +BUILT_SOURCES = $(MODFILES) +nodist_include_HEADERS = $(MODFILES) + +include $(top_srcdir)/mkmods.mk diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 new file mode 100644 index 0000000000..b804a175e0 --- /dev/null +++ b/string_utils/fms_string_utils.F90 @@ -0,0 +1,148 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @defgroup fms_string_utils_mod fms_string_utils_mod +!> @ingroup string_utils +!> @brief Routines to use for string manipulation + +!> @file +!> @brief File for @ref fms_string_utils_mod + +!> @addtogroup fms_string_utils_mod +!> @{ +module fms_string_utils_mod + use, intrinsic :: iso_c_binding + use fms_mod, only: fms_c2f_string + use mpp_mod + + implicit none + private + + public :: fms_array_to_pointer + public :: fms_pointer_to_array + public :: fms_sort_this + public :: fms_find_my_string +!> @} + + interface + !> @brief Sorts an array of pointers (my pointer) of size (p_size) in + !! alphabetical order. + subroutine fms_sort_this(my_pointer, p_size, indices) bind(c) + use iso_c_binding + + type(c_ptr), intent(inout) :: my_pointer(*) !< IN: Array of c pointers to sort + !! OUT: Sorted array of c pointers + integer(kind=c_int), intent(in) :: p_size !< Size of the array + integer(kind=c_int), intent(inout) :: indices(*) !< IN: Array of the indices of my_pointer + !! OUT: Sorted array of indices + end subroutine fms_sort_this + + !> @brief Private c function that finds a string in a SORTED array of c pointers + !! @return Indices of my_pointer where the string was found as a string!!! + function fms_find_my_string_binding(my_pointer, p_size, string_to_find, nfound) bind(c) & + result(indices) + use iso_c_binding + + type(c_ptr), intent(in) :: my_pointer(*) !< Array of sorted c pointer + integer(kind=c_int), intent(in) :: p_size !< Size of the array + character(kind=c_char), intent(in) :: string_to_find(*) !< String to find + integer(kind=c_int), intent(inout) :: nfound !< Number of times the array was found + + type(c_ptr) :: indices + end function fms_find_my_string_binding + + end interface + + !> @addtogroup fms_string_utils_mod + !> @{ + contains + + !> @brief Converts a character array to an array of c pointers! + !! @return An array of c pointers + function fms_array_to_pointer(my_array) & + result(my_pointer) + character(len=*), target :: my_array(:) !!< Array of strings to convert + type(c_ptr), allocatable :: my_pointer(:) + + integer :: i !< For do loops + + if (allocated(my_pointer)) call mpp_error(FATAL, "The c pointer array is & + already allocated. Deallocated before calling fms_array_to_pointer") + allocate(my_pointer(size(my_array))) + + do i = 1, size(my_array) + my_pointer(i) = c_loc(my_array(i)) + enddo + end function fms_array_to_pointer + + !> @brief Convert an array of c pointers back to a character array + !! @return A character array + function fms_pointer_to_array(my_pointer, narray) & + result(my_array) + type(c_ptr), intent(in) :: my_pointer(*) !< Array of c pointer + integer, intent(in) :: narray !< Length of the array + character(len=:), allocatable :: my_array(:) + + character(len=:), allocatable :: buffer !< Buffer to store a string + integer :: i !< For do loops + + allocate(character(len=255) :: my_array(narray)) + do i = 1, narray + buffer = fms_c2f_string(my_pointer(i)) + my_array(i) = buffer + deallocate(buffer) + enddo + end function fms_pointer_to_array + + !> @brief Searches through a SORTED array of pointers for a string + !! @return the indices where the array was found + !! If the string was not found, indices will be indices(1) = -999 + !>
Example usage: + !! my_pointer = fms_array_to_pointer(my_array) + !! call fms_sort_this(my_pointer, n_array, indices) + !! ifind = fms_find_my_string(my_pointer, n_array, string_to_find) + function fms_find_my_string(my_pointer, narray, string_to_find) & + result(ifind) + type(c_ptr), intent(in) :: my_pointer(*) !< Array of c pointer + integer, intent(in) :: narray !< Length of the array + character(len=*), intent(in) :: string_to_find !< string to find + integer, allocatable :: ifind(:) + + integer :: nfind !< number of times the string was found + character(len=:), allocatable :: buffer !< buffer to read the indices into + + buffer = fms_c2f_string(& + fms_find_my_string_binding(my_pointer, narray, trim(string_to_find)//c_null_char, nfind)) + + if (allocated(ifind)) call mpp_error(FATAL, "The indices array is already allocated. & + Deallocate it before calling fms_find_my_string") + + if (nfind .gt. 0) then + allocate(ifind(nfind)) + read(buffer,*) ifind + else + allocate(ifind(1)) + ifind = -999 + endif + + end function fms_find_my_string + +end module fms_string_utils_mod +!> @} +! close documentation grouping diff --git a/string_utils/fms_string_utils_binding.c b/string_utils/fms_string_utils_binding.c new file mode 100644 index 0000000000..98805a8791 --- /dev/null +++ b/string_utils/fms_string_utils_binding.c @@ -0,0 +1,164 @@ +/*********************************************************************** + * 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 . + **********************************************************************/ + +#include +#include +#include +#include + +// struct to store a string and id associated with that string +typedef struct{ + char arr_name[255]; + int id; +}my_type; + +// Compares two my_type types by the arr_name +static int arr_name_sorter(const void* p1, const void* p2) +{ + const my_type *the_type1 = p1; + const my_type *the_type2 = p2; + + return strcmp(the_type1->arr_name, the_type2->arr_name); +} + +// Sorts an array of strings in alphabetical order +// Implements a binary search to search for a string in an array of strings +// arr -> pointer of character array +// n -> length of the array +// id - > indices of the character array +void fms_sort_this(char **arr, int* n, int* id) +{ + int i; // For do loops + my_type *the_type; + + // Save the array and the id into a struct + the_type = (my_type*)calloc(*n, sizeof(my_type)); + for(i=0; i<*n; i++){ + the_type[i].id = id[i]; + strcpy(the_type[i].arr_name, arr[i]); + } + + qsort(the_type, *n, sizeof(my_type), arr_name_sorter); + + // Copy the sorted array and the sorted ids + for(i=0; i<*n; i++){ + id[i] = the_type[i].id; + strcpy(arr[i], the_type[i].arr_name); + } +} + +// Implements a binary search to search for a string in an array of strings +// arr -> pointer of character array +// n -> length of the array +// find me -> string to find +// np -> the number of times the string was found +// returns a string with the indices ;) +char* fms_find_my_string_binding(char** arr, int *n, char *find_me, int *np) +{ + int L= 0; // Left bound + int R = *n; // Right bound + int m; // Middle of the bound + int mm; // Index currently looking at + int is_found; // Result from strcmp: 0 if string was found <0 if the string is "less" >0 if the string is "greater" + int *p; // Array to store the indices + int i; // For do loops + + *np = 0; + is_found = -1; + while(L != R){ + // Start looking in the midle of the array + m = ceil((L + R) / 2); + //printf("L is set to %i from L=%i and R=%i \n", m, L, R); + + //printf("Checking %i:%s \n", m, (arr[m])); + is_found = strcmp(find_me,(arr[m])); + if (is_found == 0) + { + *np = 1; + p = malloc(sizeof(int) * *np); + p[*np-1] = m + 1; //Because fortran indices start at 1 ;) + //printf("Array found at %i %i %i \n", *np, m, p[*np-1]); + + // The string can be found in multiple indices of the array, so look to the left of the index where the string + // was initially found + mm = m; + while (is_found == 0) { + if (mm != 0) { // Only look to the left if m is not the begining of the array + mm= mm -1; + is_found = strcmp(find_me,(arr[mm])); + if (is_found == 0 ) { + *np = *np + 1; + p = realloc(p, sizeof(int) * *np); + p[*np-1] = mm + 1; + //printf("Array found at %i %i %i\n", *np, mm, p[*np-1]); + } + } else {is_found = -999;} //Done looking + } + // The string can be found in multiple indices of the array, so look to the right of the index where the string was + // initially found + mm = m; + is_found =0; + while (is_found == 0) { + if (mm != *n-1) { // Only look to the right if m is not the end of the array + mm = mm + 1; + is_found = strcmp(find_me,(arr[mm])); + if (is_found == 0 ) { + *np = *np + 1; + p = realloc(p, sizeof(int) * *np); + p[*np-1] = mm + 1; + //printf("Array found at %i %i %i\n", *np, mm, p[*np-1]); + } + } else {is_found = -999;} //Done looking} + } + L = R; + // If find_me is greater than arr[m] (i.e find_me="potato" is greater than arr[m]="banana") + } else if (is_found > 0) { + // Set the lower bound to start in m (ignore the first half) + L = m + 1; + //printf("L is set to %i \n", L); + } else + // If find_me is less than arr[m] (i.e find_me="potato" is less than arr[m] = "soccer") + { + // Set the upper bound to start in m (ignore the lower half) + R = m; + //printf("R is set to %i \n", R); + } + +} + + // This is the magical part: + // Save the array of indices where the string was found into a string + // The fortran side is going to allocate the array to the correct size and read the string into the array + // The alternative (normal) way is to have a seperate function that gets the number of times the string is found + // The fortran side will allocate the array to the correct size and send that into another function that + // fill in that array. That will require you to search through the array twice ... + char string[255]; + char *string_p; + + strcpy(string, ""); + + for(i=0; i<*np; i++){ + if (i == *np-1) {sprintf( &string[ strlen(string) ], "%d ", p[i] );} + else {sprintf( &string[ strlen(string) ], "%d ,", p[i] );} + } + + string_p = (char*) malloc((strlen(string)+1)*sizeof(char)); + strcpy(string_p, string); + return string_p; +} diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 639a69c5b0..f109f859b8 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -26,7 +26,7 @@ ACLOCAL_AMFLAGS = -I m4 # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = coupler diag_manager data_override exchange monin_obukhov drifters \ mosaic interpolator fms mpp mpp_io time_interp time_manager \ -horiz_interp field_manager axis_utils affinity fms2_io parser +horiz_interp field_manager axis_utils affinity fms2_io parser string_utils # This input file must be distributed, it is turned into # test_common.sh by configure. diff --git a/test_fms/parser/test_yaml_parser.F90 b/test_fms/parser/test_yaml_parser.F90 index bfb6259c3f..9f659a5ab8 100644 --- a/test_fms/parser/test_yaml_parser.F90 +++ b/test_fms/parser/test_yaml_parser.F90 @@ -46,6 +46,7 @@ program test_read_and_parse_file integer, allocatable :: key_ids(:) !< array of key ids character(len=20) :: key_name !< the name of the key character(len=20) :: key_value !< the value of a key +logical :: logical_buffer !< logical buffer call fms_init @@ -117,6 +118,15 @@ program test_read_and_parse_file call get_value_from_key(yaml_file_id1, variable_ids(1), "fill_value", r8_buffer) if (abs(r8_buffer - real(-999.9, kind=r8_kind)) .gt. 5d-5) call mpp_error(FATAL, "fill_value was not read correctly as an r8!") +!! Try get_value_from_key using a logical buffer +logical_buffer = .true. +call get_value_from_key(yaml_file_id2, entries_ids(2), "do_data_bug", logical_buffer) +if (logical_buffer) call mpp_error(FATAL, "do_data_bug was not read correctly as a logical") + +logical_buffer = .false. +call get_value_from_key(yaml_file_id2, entries_ids(2), "use_data_bug", logical_buffer) +if (.not. logical_buffer) call mpp_error(FATAL, "use_data_bug was not read correctly as a logical") + !! Try the is_optional argument on an key that does not exist string_buffer = "" call get_value_from_key(yaml_file_id1, variable_ids(1), "NANANANA", string_buffer, is_optional=.true.) diff --git a/test_fms/parser/test_yaml_parser.sh b/test_fms/parser/test_yaml_parser.sh index de134653d5..c7d9a7f424 100755 --- a/test_fms/parser/test_yaml_parser.sh +++ b/test_fms/parser/test_yaml_parser.sh @@ -46,6 +46,8 @@ data_table: lat_end : 89.8 lon_start : 3.4 lon_end : 154.4 + do_data_bug : false + use_data_bug : True _EOF cat <<_EOF > diag_table.yaml diff --git a/test_fms/string_utils/Makefile.am b/test_fms/string_utils/Makefile.am new file mode 100644 index 0000000000..7c46c5fbb7 --- /dev/null +++ b/test_fms/string_utils/Makefile.am @@ -0,0 +1,44 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the test_fms/data_override directory of the FMS +# package. + +# uramirez + +# Find the needed mod and .inc files. +AM_CPPFLAGS = -I${top_srcdir}/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = ${top_builddir}/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_string_utils + +# This is the source code for the test. +test_string_utils_SOURCES = test_string_utils.F90 + +# Run the test program. +TESTS = test_string_utils.sh + +# Include these files with the distribution. +EXTRA_DIST = test_string_utils.sh + +# Clean up +CLEANFILES = input.nml *.out diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 new file mode 100644 index 0000000000..f75cc99b29 --- /dev/null +++ b/test_fms/string_utils/test_string_utils.F90 @@ -0,0 +1,158 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @brief This programs tests the public subroutines in test_fms_string_utils: +!! fms_array_to_pointer, fms_pointer_to_array, fms_sort_this, fms_find_my_string +program test_fms_string_utils + use fms_string_utils_mod + use fms_mod, only: fms_init, fms_end + use mpp_mod + use, intrinsic :: iso_c_binding + + implicit none + + character(len=10), allocatable :: my_array(:) !< Array of strings + character(len=:), allocatable :: my_sorted_array(:) !< Sorted array of strings + type(c_ptr), allocatable :: my_pointer(:) !< Array of pointers + integer, allocatable :: my_ids(:) !< Array of indices + integer :: i !< For do loops + integer, allocatable :: ifind(:) !< Array of indices where a string was found + + call fms_init() + + allocate(my_array(10)) + allocate(my_ids(10)) + + my_array(1) = "golf"//c_null_char + my_array(2) = "charlie"//c_null_char + my_array(3) = "golf"//c_null_char + my_array(4) = "beta"//c_null_char + my_array(5) = "alpha"//c_null_char + my_array(6) = "foxtrop"//c_null_char + my_array(7) = "golf"//c_null_char + my_array(8) = "foxtrop"//c_null_char + my_array(9) = "juliet"//c_null_char + my_array(10) ="india"//c_null_char + + do i=1, 10 + my_ids(i) = i + end do + + my_pointer = fms_array_to_pointer(my_array) + call fms_sort_this(my_pointer, 10, my_ids) + my_sorted_array = fms_pointer_to_array(my_pointer, 10) + print *, "Checking if the array was sorted correctly" + call check_my_sorted_array(my_sorted_array) + + ifind = fms_find_my_string(my_pointer, 10, "alpha") + print *, "Checking if 'alpha' was found in the array at all the right places" + call check_my_indices(ifind, (/1/), "alpha") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "beta") + print *, "Checking if 'beta' was found in the array at all the right places" + call check_my_indices(ifind, (/2/), "beta") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "charlie") + print *, "Checking if 'charlie' was found in the array at all the right places" + call check_my_indices(ifind, (/3/), "charlie") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "foxtrop") + print *, "Checking if 'foxtrop' was found in the array at all the right places" + call check_my_indices(ifind, (/5,4/), "foxtrop") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "golf") + print *, "Checking if 'golf' was found in the array at all the right places" + call check_my_indices(ifind, (/6,7,8/), "golf") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "india") + print *, "Checking if 'india' was found in the array at all the right places" + call check_my_indices(ifind, (/9/), "india") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "juliet") + print *, "Checking if 'juliet' was found in the array at all the right places" + call check_my_indices(ifind, (/10/), "juliet") + deallocate(ifind) + + ifind = fms_find_my_string(my_pointer, 10, "tamales") + print *, "Checking if 'tamales' was found in the array at all the right places" + call check_my_indices(ifind, (/-999/), "tamales") + deallocate(ifind) + + call fms_end() + + deallocate(my_array) + deallocate(my_ids) + deallocate(my_pointer) + + contains + + !< Checks if the array was sorted correctly! + subroutine check_my_sorted_array(sorted_array) + character(len=*), intent(in) :: sorted_array(:) !< Array of sorted strings + integer :: j !< For do loops + character(len=10) :: ans(10) !< Expected array of sorted strings + + ans(1) = "alpha"//c_null_char + ans(2) = "beta"//c_null_char + ans(3) = "charlie"//c_null_char + ans(4) = "foxtrop"//c_null_char + ans(5) = "foxtrop"//c_null_char + ans(6) = "golf"//c_null_char + ans(7) = "golf"//c_null_char + ans(8) = "golf"//c_null_char + ans(9) = "india"//c_null_char + ans(10) = "juliet"//c_null_char + + do j = 1, size(ans) + print *, "Comparing ", trim(sorted_array(j)), " and ", trim(ans(j)) + if (trim(sorted_array(j)) .eq. trim(ans(j))) & + call mpp_error(FATAL, "The sorted array is not correct!") + end do + + end subroutine check_my_sorted_array + + !< Checks if an array of integers is the expected result + subroutine check_my_indices(indices, ans, string) + integer, intent(in) :: indices(:) !< Array of indices + integer, intent(in) :: ans(:) !< Expected answers + character(len=*), intent(in) :: string !< Name of field comparing + + integer :: j !< For do loops + + if (size(indices) .ne. size(ans)) then + print *, "The size of ", trim(string), " is ", size(indices) + call mpp_error(FATAL, "The size of the indices where "//trim(string)//" was found is not correct") + endif + + do j = 1, size(indices) + print *, "Checking if the ", j, " index is ", ans(j) + if (indices(j) .ne. ans(j)) then + print *, "The indices of ", trim(string), " are ", indices + call mpp_error(FATAL, "The indices where "//trim(string)//" was found is not correct") + endif + end do + end subroutine check_my_indices + +end program test_fms_string_utils diff --git a/test_fms/string_utils/test_string_utils.sh b/test_fms/string_utils/test_string_utils.sh new file mode 100755 index 0000000000..75e4f09e2a --- /dev/null +++ b/test_fms/string_utils/test_string_utils.sh @@ -0,0 +1,29 @@ +#!/bin/sh + +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/string_utils directory. + +# Set common test settings. +. ../test_common.sh + +touch input.nml +run_test test_string_utils 1 From 207ed12ede4f5fd496437a0574a7de12eca597fd Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Tue, 8 Mar 2022 07:02:19 -0500 Subject: [PATCH 029/142] Resolves conflicts with 2022.01-beta2 and dmUpdate branch #931 --- ...am4_regression_parallelWorks_intel_tag.yml | 4 +- .github/workflows/build_cmake_gnu.yml | 4 +- .github/workflows/lint_fms.yml | 2 +- .github/workflows/parallelWorks_intel_pr.yml | 2 +- .github/workflows/update_docs.yml | 2 +- .gitignore | 1 - Makefile.am | 4 +- affinity/affinity.c | 3 + amip_interp/amip_interp.F90 | 9 +- astronomy/astronomy.F90 | 23 +- axis_utils/axis_utils.F90 | 4 +- axis_utils/axis_utils2.F90 | 4 +- configure.ac | 31 +- constants/constants.F90 | 56 +- coupler/atmos_ocean_fluxes.F90 | 41 +- coupler/coupler_types.F90 | 69 +- coupler/ensemble_manager.F90 | 3 +- data_override/data_override.F90 | 20 +- data_override/get_grid_version.F90 | 6 +- diag_manager/diag_axis.F90 | 12 +- diag_manager/diag_data.F90 | 18 +- diag_manager/diag_grid.F90 | 6 +- diag_manager/diag_manager.F90 | 212 +- diag_manager/diag_output.F90 | 75 +- diag_manager/diag_table.F90 | 216 +- diag_manager/diag_util.F90 | 61 +- diag_manager/fms_diag_object_container.F90 | 2 +- diag_manager/fms_diag_yaml.F90 | 11 +- docs/layout.xml | 4 +- drifters/cloud_interpolator.F90 | 3 +- drifters/drifters.F90 | 2 +- drifters/drifters_core.F90 | 6 +- exchange/stock_constants.F90 | 21 +- exchange/xgrid.F90 | 39 +- field_manager/field_manager.F90 | 12 +- field_manager/fm_util.F90 | 18 +- fms/fms.F90 | 5 +- fms/fms_io.F90 | 215 +- fms/fms_io_unstructured_field_exist.inc | 9 +- fms/fms_io_unstructured_file_unit.inc | 3 +- fms/fms_io_unstructured_get_field_size.inc | 27 +- fms/fms_io_unstructured_get_file_name.inc | 3 +- fms/fms_io_unstructured_get_file_unit.inc | 3 +- fms/fms_io_unstructured_read.inc | 9 +- ..._io_unstructured_register_restart_axis.inc | 48 +- ...io_unstructured_register_restart_field.inc | 108 +- fms/fms_io_unstructured_save_restart.inc | 69 +- fms/fms_io_unstructured_setup_one_field.inc | 24 +- fms2_io/fms_io_utils.F90 | 9 +- fms2_io/fms_netcdf_domain_io.F90 | 42 +- fms2_io/include/compute_global_checksum.inc | 9 +- fms2_io/include/domain_read.inc | 24 +- fms2_io/include/domain_write.inc | 24 +- fms2_io/include/get_global_attribute.inc | 20 +- fms2_io/include/get_variable_attribute.inc | 14 +- .../include/netcdf_add_restart_variable.inc | 3 +- fms2_io/include/register_global_attribute.inc | 20 +- .../include/register_variable_attribute.inc | 14 +- fms2_io/include/scatter_data_bc.inc | 6 +- fms2_io/netcdf_io.F90 | 22 +- horiz_interp/horiz_interp.F90 | 6 +- horiz_interp/horiz_interp_bicubic.F90 | 27 +- horiz_interp/horiz_interp_conserve.F90 | 37 +- horiz_interp/horiz_interp_type.F90 | 16 +- interpolator/interpolator.F90 | 96 +- libFMS/Makefile.am | 4 +- mkmods.mk | 4 +- mosaic/gradient.F90 | 33 +- mosaic/grid.F90 | 61 +- mosaic/read_mosaic.c | 14 +- mosaic2/grid2.F90 | 14 +- mpp/include/mpp_chksum_int.h | 2 +- mpp/include/mpp_comm_mpi.inc | 3 +- mpp/include/mpp_comm_nocomm.inc | 3 +- mpp/include/mpp_define_nest_domains.inc | 117 +- mpp/include/mpp_do_check.h | 3 +- mpp/include/mpp_do_checkV.h | 6 +- mpp/include/mpp_do_global_field.h | 45 +- mpp/include/mpp_do_global_field_ad.h | 27 +- mpp/include/mpp_do_updateV.h | 9 +- mpp/include/mpp_do_updateV_ad.h | 9 +- mpp/include/mpp_do_updateV_nonblock.h | 24 +- mpp/include/mpp_do_update_nest.h | 10 +- mpp/include/mpp_do_update_nonblock.h | 3 +- mpp/include/mpp_domains_comm.inc | 16 +- mpp/include/mpp_domains_define.inc | 231 +- mpp/include/mpp_domains_misc.inc | 6 +- mpp/include/mpp_domains_util.inc | 19 +- mpp/include/mpp_global_field_ug.h | 3 +- mpp/include/mpp_global_reduce.h | 5 +- mpp/include/mpp_global_sum.h | 15 +- mpp/include/mpp_global_sum_ad.h | 12 +- mpp/include/mpp_group_update.h | 18 +- mpp/include/mpp_io_connect.inc | 63 +- mpp/include/mpp_io_misc.inc | 9 +- mpp/include/mpp_io_read.inc | 92 +- mpp/include/mpp_io_unstructured_read.inc | 54 +- mpp/include/mpp_io_unstructured_write.inc | 290 +- mpp/include/mpp_io_util.inc | 3 +- mpp/include/mpp_io_write.inc | 34 +- mpp/include/mpp_read_2Ddecomp.h | 3 +- mpp/include/mpp_read_compressed.h | 6 +- mpp/include/mpp_sum_nocomm.h | 3 +- mpp/include/mpp_transmit_mpi.h | 12 +- mpp/include/mpp_transmit_nocomm.h | 12 +- mpp/include/mpp_unstruct_domain.inc | 12 +- mpp/include/mpp_update_domains2D.h | 40 +- mpp/include/mpp_update_domains2D_ad.h | 12 +- mpp/include/mpp_update_domains2D_nonblock.h | 85 +- mpp/include/mpp_update_nest_domains.h | 75 +- mpp/include/mpp_util.inc | 30 +- mpp/include/mpp_write_2Ddecomp.h | 3 +- mpp/include/mpp_write_compressed.h | 3 +- mpp/include/mpp_write_unlimited_axis.h | 6 +- mpp/mpp.F90 | 6 +- mpp/mpp_domains.F90 | 27 +- mpp/mpp_io.F90 | 8 +- parser/yaml_parser.F90 | 72 +- parser/yaml_parser_binding.c | 4 +- sat_vapor_pres/sat_vapor_pres.F90 | 3 +- supported_interfaces.md | 2 +- tap-driver.sh | 678 ++ test_fms/Makefile.am | 2 +- test_fms/affinity/Makefile.am | 6 +- test_fms/affinity/input_base.nml | 2 - test_fms/affinity/test_affinity2.sh | 26 +- test_fms/axis_utils/Makefile.am | 4 + test_fms/axis_utils/test_axis_utils2.sh | 15 +- test_fms/coupler/Makefile.am | 4 + test_fms/coupler/test_coupler.sh | 13 +- test_fms/coupler/test_coupler_2d.F90 | 12 +- test_fms/coupler/test_coupler_3d.F90 | 12 +- test_fms/data_override/Makefile.am | 10 +- test_fms/data_override/data_table_base | 4 - test_fms/data_override/diag_table_base | 9 - test_fms/data_override/input_base.nml | 19 - test_fms/data_override/test_data_override.F90 | 25 +- test_fms/data_override/test_data_override2.sh | 95 +- .../test_data_override_ongrid.F90 | 5 +- test_fms/diag_manager/Makefile.am | 9 +- test_fms/diag_manager/check_crashes.sh | 210 +- .../diag_manager/diagTables/diag_table_01 | 8 - .../diag_manager/diagTables/diag_table_02 | 8 - .../diag_manager/diagTables/diag_table_03 | 8 - .../diag_manager/diagTables/diag_table_04 | 10 - .../diag_manager/diagTables/diag_table_05 | 10 - .../diag_manager/diagTables/diag_table_06 | 10 - .../diag_manager/diagTables/diag_table_07 | 8 - .../diag_manager/diagTables/diag_table_08 | 10 - .../diag_manager/diagTables/diag_table_09 | 8 - .../diag_manager/diagTables/diag_table_10 | 8 - .../diag_manager/diagTables/diag_table_11 | 8 - .../diag_manager/diagTables/diag_table_12 | 11 - .../diag_manager/diagTables/diag_table_13 | 12 - .../diag_manager/diagTables/diag_table_14 | 9 - .../diag_manager/diagTables/diag_table_15 | 9 - .../diag_manager/diagTables/diag_table_16 | 9 - .../diag_manager/diagTables/diag_table_17 | 9 - .../diag_manager/diagTables/diag_table_18 | 12 - .../diag_manager/diagTables/diag_table_19 | 11 - .../diag_manager/diagTables/diag_table_20 | 11 - .../diag_manager/diagTables/diag_table_21 | 9 - .../diag_manager/diagTables/diag_table_22 | 9 - .../diag_manager/diagTables/diag_table_23 | 12 - .../diag_manager/diagTables/diag_table_24 | 14 - .../diag_manager/diagTables/diag_table_25 | 9 - .../diagTables/diag_table_yaml_26 | 61 - test_fms/diag_manager/input.nml_base | 21 - test_fms/diag_manager/test_diag_manager.F90 | 326 +- test_fms/diag_manager/test_diag_manager2.sh | 628 +- .../diag_manager/test_diag_manager_time.F90 | 4 +- .../test_diag_object_container.F90 | 3 +- test_fms/diag_manager/test_diag_yaml.F90 | 11 +- test_fms/drifters/Makefile.am | 6 +- test_fms/drifters/input_base.nml | 10 - test_fms/drifters/test_drifters2.sh | 43 +- test_fms/drifters/test_drifters_comm.F90 | 2 + test_fms/exchange/Makefile.am | 7 +- test_fms/exchange/input_base.nml | 15 - test_fms/exchange/test_xgrid.F90 | 17 +- test_fms/exchange/test_xgrid2.sh | 37 +- test_fms/fft/test_fft2.sh | 39 - test_fms/field_manager/Makefile.am | 6 +- test_fms/field_manager/field_table_base | 14 - test_fms/field_manager/input_base.nml | 3 - test_fms/field_manager/test_field_manager2.sh | 31 +- test_fms/fms/Makefile.am | 5 + test_fms/fms/test_fms.F90 | 6 +- test_fms/fms/test_fms2.sh | 14 +- test_fms/fms2_io/Makefile.am | 10 +- test_fms/fms2_io/test_atmosphere_io.sh | 35 +- test_fms/fms2_io/test_bc_restart.F90 | 3 +- test_fms/fms2_io/test_bc_restart.sh | 31 +- test_fms/fms2_io/test_fms2_io.sh | 27 +- test_fms/fms2_io/test_global_att.F90 | 12 +- test_fms/fms2_io/test_global_att.sh | 11 +- test_fms/fms2_io/test_io_simple.sh | 35 +- test_fms/fms2_io/test_io_with_mask.sh | 12 +- test_fms/fms2_io/test_read_ascii_file.sh | 12 +- test_fms/horiz_interp/Makefile.am | 7 +- test_fms/horiz_interp/input_base.nml | 9 - test_fms/horiz_interp/test_horiz_interp2.sh | 19 +- test_fms/interpolator/Makefile.am | 7 +- test_fms/interpolator/diag_table_base | 8 - test_fms/interpolator/input_base.nml | 2 - test_fms/interpolator/test_interpolator.F90 | 23 +- test_fms/interpolator/test_interpolator2.sh | 43 +- test_fms/monin_obukhov/Makefile.am | 6 +- test_fms/monin_obukhov/input_base.nml | 0 test_fms/monin_obukhov/test_monin_obukhov.F90 | 9 +- test_fms/monin_obukhov/test_monin_obukhov2.sh | 14 +- test_fms/mosaic/Makefile.am | 4 + test_fms/mosaic/test_mosaic2.sh | 9 +- test_fms/mpp/Makefile.am | 47 +- test_fms/mpp/base_ascii_0 | 0 test_fms/mpp/base_ascii_25 | 25 - test_fms/mpp/base_ascii_5 | 5 - test_fms/mpp/base_ascii_long | 5 - test_fms/mpp/base_ascii_skip | 5 - test_fms/mpp/compare_data_checksums.F90 | 11 +- test_fms/mpp/fill_halo.F90 | 18 +- test_fms/mpp/input_base.nml | 63 - test_fms/mpp/test_chksum_int.sh | 36 +- test_fms/mpp/test_clock_init.sh | 10 +- test_fms/mpp/test_domains_utility_mod.F90 | 204 +- test_fms/mpp/test_global_arrays.F90 | 23 +- test_fms/mpp/test_global_arrays.sh | 35 +- test_fms/mpp/test_minmax.sh | 36 +- test_fms/mpp/test_mpp.F90 | 3 +- test_fms/mpp/test_mpp2.sh | 35 +- test_fms/mpp/test_mpp_alltoall.F90 | 12 +- test_fms/mpp/test_mpp_alltoall.sh | 11 +- test_fms/mpp/test_mpp_broadcast.sh | 9 +- test_fms/mpp/test_mpp_clock_begin_end_id.F90 | 299 + test_fms/mpp/test_mpp_clock_begin_end_id.sh | 118 + test_fms/mpp/test_mpp_domains.F90 | 6648 +++++------------ test_fms/mpp/test_mpp_domains2.sh | 201 +- test_fms/mpp/test_mpp_gatscat.sh | 34 +- test_fms/mpp/test_mpp_get_ascii_lines2.sh | 82 +- test_fms/mpp/test_mpp_global_field.F90 | 72 +- test_fms/mpp/test_mpp_global_field.sh | 9 +- test_fms/mpp/test_mpp_global_field_ug.F90 | 10 +- test_fms/mpp/test_mpp_global_field_ug.sh | 10 +- test_fms/mpp/test_mpp_global_sum_ad.sh | 35 +- test_fms/mpp/test_mpp_init_logfile.F90 | 44 + test_fms/mpp/test_mpp_init_logfile.sh | 69 + test_fms/mpp/test_mpp_mem_dump.sh | 34 + test_fms/mpp/test_mpp_memuse.sh | 34 + test_fms/mpp/test_mpp_memutils_mod.sh | 29 +- test_fms/mpp/test_mpp_nesting.F90 | 4667 ++++++++++++ test_fms/mpp/test_mpp_nesting.sh | 105 + test_fms/mpp/test_mpp_npes.sh | 33 +- test_fms/mpp/test_mpp_pe.sh | 29 +- test_fms/mpp/test_mpp_root_pe.sh | 29 +- test_fms/mpp/test_mpp_sendrecv.sh | 35 +- test_fms/mpp/test_mpp_sum.F90 | 48 +- test_fms/mpp/test_mpp_sum.sh | 8 +- test_fms/mpp/test_mpp_transmit.sh | 8 +- test_fms/mpp/test_mpp_update_domains.sh | 25 +- test_fms/mpp/test_mpp_update_domains_ad.sh | 25 +- test_fms/mpp/test_mpp_update_domains_real.F90 | 6 +- test_fms/mpp/test_peset.sh | 28 +- test_fms/mpp/test_read_ascii_file.F90 | 2 +- test_fms/mpp/test_read_ascii_file.sh | 99 +- test_fms/mpp/test_read_input_nml.F90 | 2 +- test_fms/mpp/test_read_input_nml2.sh | 41 +- test_fms/mpp/test_redistribute_int.F90 | 12 +- test_fms/mpp/test_redistribute_int.sh | 35 +- test_fms/mpp/test_stderr.sh | 9 +- test_fms/mpp/test_stdin.F90 | 45 + test_fms/mpp/test_stdin.sh | 32 + test_fms/mpp/test_stdout.sh | 36 +- test_fms/mpp/test_super_grid.sh | 7 +- test_fms/mpp/test_system_clock.sh | 7 +- .../mpp/test_update_domains_performance.F90 | 19 +- .../mpp/test_update_domains_performance.sh | 25 +- test_fms/mpp_io/Makefile.am | 8 +- test_fms/mpp_io/input_base.nml | 12 - test_fms/mpp_io/test_io_R4_R8.sh | 59 +- test_fms/mpp_io/test_io_mosaic_R4_R8.F90 | 42 +- test_fms/mpp_io/test_io_mosaic_R4_R8.sh | 36 +- test_fms/mpp_io/test_mpp_io.F90 | 36 +- test_fms/mpp_io/test_mpp_io2.sh | 53 +- test_fms/parser/Makefile.am | 5 + test_fms/parser/check_crashes.F90 | 10 +- test_fms/parser/test_yaml_parser.F90 | 10 +- test_fms/parser/test_yaml_parser.sh | 172 +- test_fms/string_utils/Makefile.am | 5 + test_fms/string_utils/test_string_utils.sh | 8 +- test_fms/test-lib.sh.in | 330 + test_fms/test_common.sh.in | 63 - test_fms/time_interp/Makefile.am | 5 +- test_fms/time_interp/test_time_interp.F90 | 9 +- test_fms/time_interp/test_time_interp2.sh | 18 +- .../time_interp/test_time_interp_external.F90 | 15 +- test_fms/time_manager/Makefile.am | 10 +- test_fms/time_manager/input_base.nml | 21 - test_fms/time_manager/test_time_manager.F90 | 29 +- test_fms/time_manager/test_time_manager2.sh | 63 +- time_interp/time_interp.F90 | 5 +- time_interp/time_interp_external.F90 | 21 +- time_interp/time_interp_external2.F90 | 21 +- time_manager/get_cal_time.F90 | 15 +- time_manager/time_manager.F90 | 26 +- tracer_manager/tracer_manager.F90 | 16 +- 305 files changed, 12994 insertions(+), 8529 deletions(-) create mode 100755 tap-driver.sh delete mode 100644 test_fms/affinity/input_base.nml delete mode 100644 test_fms/data_override/data_table_base delete mode 100644 test_fms/data_override/diag_table_base delete mode 100644 test_fms/data_override/input_base.nml delete mode 100644 test_fms/diag_manager/diagTables/diag_table_01 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_02 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_03 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_04 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_05 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_06 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_07 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_08 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_09 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_10 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_11 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_12 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_13 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_14 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_15 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_16 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_17 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_18 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_19 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_20 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_21 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_22 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_23 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_24 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_25 delete mode 100644 test_fms/diag_manager/diagTables/diag_table_yaml_26 delete mode 100644 test_fms/diag_manager/input.nml_base delete mode 100644 test_fms/drifters/input_base.nml delete mode 100644 test_fms/exchange/input_base.nml delete mode 100755 test_fms/fft/test_fft2.sh delete mode 100644 test_fms/field_manager/field_table_base delete mode 100644 test_fms/field_manager/input_base.nml delete mode 100644 test_fms/horiz_interp/input_base.nml delete mode 100644 test_fms/interpolator/diag_table_base delete mode 100644 test_fms/interpolator/input_base.nml delete mode 100644 test_fms/monin_obukhov/input_base.nml delete mode 100644 test_fms/mpp/base_ascii_0 delete mode 100644 test_fms/mpp/base_ascii_25 delete mode 100644 test_fms/mpp/base_ascii_5 delete mode 100644 test_fms/mpp/base_ascii_long delete mode 100644 test_fms/mpp/base_ascii_skip delete mode 100755 test_fms/mpp/input_base.nml create mode 100644 test_fms/mpp/test_mpp_clock_begin_end_id.F90 create mode 100755 test_fms/mpp/test_mpp_clock_begin_end_id.sh create mode 100644 test_fms/mpp/test_mpp_init_logfile.F90 create mode 100755 test_fms/mpp/test_mpp_init_logfile.sh create mode 100755 test_fms/mpp/test_mpp_mem_dump.sh create mode 100755 test_fms/mpp/test_mpp_memuse.sh create mode 100644 test_fms/mpp/test_mpp_nesting.F90 create mode 100755 test_fms/mpp/test_mpp_nesting.sh create mode 100644 test_fms/mpp/test_stdin.F90 create mode 100755 test_fms/mpp/test_stdin.sh delete mode 100755 test_fms/mpp_io/input_base.nml create mode 100644 test_fms/test-lib.sh.in delete mode 100644 test_fms/test_common.sh.in delete mode 100644 test_fms/time_manager/input_base.nml diff --git a/.github/workflows/am4_regression_parallelWorks_intel_tag.yml b/.github/workflows/am4_regression_parallelWorks_intel_tag.yml index d4b8db8b19..7c4cbf4978 100644 --- a/.github/workflows/am4_regression_parallelWorks_intel_tag.yml +++ b/.github/workflows/am4_regression_parallelWorks_intel_tag.yml @@ -1,5 +1,5 @@ name: Tag CI libFMS with AM4 regression - + on: push: tags: @@ -14,7 +14,7 @@ jobs: max-parallel: 3 matrix: include: -# Runs AM4 with intel18 on AM4_intel18 +# Runs AM4 with intel18 on AM4_intel18 # - runname: AM4 build and run with intel 18 # runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/AM4_intel18StartClusters.py am4_intel18 # Runs AM4 using a container to build and run the model with intel 21 diff --git a/.github/workflows/build_cmake_gnu.yml b/.github/workflows/build_cmake_gnu.yml index d031c0c6b4..f5eaca2bb9 100644 --- a/.github/workflows/build_cmake_gnu.yml +++ b/.github/workflows/build_cmake_gnu.yml @@ -4,7 +4,7 @@ on: [push, pull_request] jobs: build: - runs-on: ubuntu-latest + runs-on: ubuntu-latest strategy: matrix: omp-flags: [ -DOPENMP=on, -DOPENMP=off ] @@ -16,7 +16,7 @@ jobs: steps: - name: Checkout code uses: actions/checkout@v2 - - name: Generate makefiles with CMake + - name: Generate makefiles with CMake run: cmake $CMAKE_FLAGS . - name: Build the library run: make diff --git a/.github/workflows/lint_fms.yml b/.github/workflows/lint_fms.yml index 4b831691a6..ecc783c619 100644 --- a/.github/workflows/lint_fms.yml +++ b/.github/workflows/lint_fms.yml @@ -9,4 +9,4 @@ jobs: - name: Checkout code uses: actions/checkout@v2 - name: Run Lint - uses: NOAA-GFDL/simple_lint@v2 + uses: NOAA-GFDL/simple_lint@v3 diff --git a/.github/workflows/parallelWorks_intel_pr.yml b/.github/workflows/parallelWorks_intel_pr.yml index 5c841d5681..1183eb338b 100644 --- a/.github/workflows/parallelWorks_intel_pr.yml +++ b/.github/workflows/parallelWorks_intel_pr.yml @@ -1,5 +1,5 @@ name: Pull Request CI libFMS with intel21 - + on: [pull_request,workflow_dispatch] jobs: parallelWorks: diff --git a/.github/workflows/update_docs.yml b/.github/workflows/update_docs.yml index b254cbb7ec..0327b8d2b7 100644 --- a/.github/workflows/update_docs.yml +++ b/.github/workflows/update_docs.yml @@ -9,7 +9,7 @@ jobs: steps: - name: Checkout code uses: actions/checkout@v2 - - name: Setup repo + - name: Setup repo run: | # do autotool's job for substitutes since we don't need a full build environement mkdir gen_docs sed 's/@abs_top_builddir@\/docs/gen_docs/' docs/Doxyfile.in > gen_docs/Doxyfile diff --git a/.gitignore b/.gitignore index 1d67e7bda6..cbff225070 100644 --- a/.gitignore +++ b/.gitignore @@ -36,7 +36,6 @@ Makefile.in /mdate-sh /py-compile /test-driver -/tap-driver.sh /ylwrap *.log *.trs diff --git a/Makefile.am b/Makefile.am index 1dace6e40d..7b37a8cded 100644 --- a/Makefile.am +++ b/Makefile.am @@ -84,9 +84,9 @@ AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) noinst_LTLIBRARIES = libFMS_mod.la libFMS_mod_la_SOURCES = libFMS.F90 -fms.$(FC_MODEXT): .mods/*_mod.$(FC_MODEXT) +fms.$(FC_MODEXT): .mods/*_mod.$(FC_MODEXT) -nodist_include_HEADERS = libFMS_mod.la +nodist_include_HEADERS = libFMS_mod.la include $(top_srcdir)/mkmods.mk diff --git a/affinity/affinity.c b/affinity/affinity.c index dd575e6992..ebdda2cc35 100644 --- a/affinity/affinity.c +++ b/affinity/affinity.c @@ -19,11 +19,14 @@ * License along with FMS. If not, see . **********************************************************************/ +#ifndef _GNU_SOURCE #define _GNU_SOURCE +#endif #include #include #include +#include #include #include #include diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index c7ac913d25..6f77d951ab 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -28,7 +28,8 @@ !! !! 1. AMIP @link http://www-pcmdi.llnl.gov/amip @endlink from Jan 1979 to Jan 1989 (2 deg x 2 deg) !! 2. Reynolds OI @link amip_interp.rey_oi.txt @endlink from Nov 1981 to Jan 1999 (1 deg x 1 deg) -!! 3. Reynolds EOF @link ftp://podaac.jpl.nasa.gov/pub/sea_surface_temperature/reynolds/rsst/doc/rsst.html @endlink from Jan 1950 to Dec 1998 (2 deg x 2 deg) +!! 3. Reynolds EOF @link ftp://podaac.jpl.nasa.gov/pub/sea_surface_temperature/reynolds/rsst/doc/rsst.html +!! @endlink from Jan 1950 to Dec 1998 (2 deg x 2 deg) !! !! All original data are observed monthly means. This module !! interpolates linearly in time between pairs of monthly means. @@ -500,7 +501,8 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) if (DEBUG) then call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) if (mpp_pe() == 0) then - write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) + write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5), & + & jhctod(6) write (*,300) 'JHC: use_daily = F, interped SST: ', sst(1,1),sst(5,5),sst(10,10) endif endif @@ -511,7 +513,8 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) ! add by JHC else call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) + if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1), & + & jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) yr = jhctod(1); mo = jhctod(2); dy = jhctod(3) diff --git a/astronomy/astronomy.F90 b/astronomy/astronomy.F90 index f0c40c6145..890b195425 100644 --- a/astronomy/astronomy.F90 +++ b/astronomy/astronomy.F90 @@ -129,7 +129,8 @@ module astronomy_mod !! @param [in]